
'=========================================================================
#include once "windows.bi"
'=========================================================================

'------------------------------------------------------------------
'' This function creates a DIB from a DDB and stores it in a file,
'' or fails if the bits per pixel (bpp) for the DDB is not 4, 8,
'' 16, 24, or 32, or if the bpp for the DIB, specified in bppDib,
'' is not 4, 8, or 24. There is no error checking.
'------------------------------------------------------------------

Function CreateBMPFile( Byval hbmp As HBITMAP, _
                        Byval bppDib As Integer, _
                        Byref filename As String ) As Integer

    Dim As Integer i, clrUsed
    Dim As Any Ptr pbmp
    Dim As HANDLE hFile, hHeap
    Dim As HDC hdcScreen
    Dim As BITMAPINFO Ptr pbmi
    Dim As BITMAPFILEHEADER hdr

    hHeap = GetProcessHeap
    hdcScreen = GetDC( null )

    '----------------------------------------------
    '' Allocate memory for a BITMAPINFO structure.
    '----------------------------------------------

    pbmi = HeapAlloc( hHeap, HEAP_ZERO_MEMORY, sizeof(BITMAPINFO) )

    '------------------------------------------------
    '' Set the biSize member of the BITMAPINFOHEADER
    '' structure to the size of the structure.
    '------------------------------------------------

    pbmi->bmiHeader.biSize = sizeof(BITMAPINFOHEADER)

    '---------------------------------------------------------
    '' Call the GetDIBits function with the lpvBits parameter
    '' set to NULL, so the function will pass the dimensions
    '' and format of the bitmap to the BITMAPINFO structure.
    '---------------------------------------------------------

    GetDIBits( hdcScreen, hbmp, 0, 0, null, pbmi, DIB_RGB_COLORS )

    '---------------------------------------------------
    '' Fail if the input bpp is not 4, 8, 16, 24 or 32.
    '---------------------------------------------------

    Select Case pbmi->bmiHeader.biBitCount
      Case 4, 8, 16, 24, 32
      Case Else
        HeapFree( hHeap, 0, pbmi )
        Return false
    End Select

    '-------------------------------------------------------------
    '' Set the output bpp, or fail if the bpp is not 4, 8, or 24.
    '-------------------------------------------------------------

    Select Case bppDib
      Case 4, 8, 24
        pbmi->bmiHeader.biBitCount = bppDib
      Case Else
        HeapFree( hHeap, 0, pbmi )
        Return false
    End Select

    '---------------------------------------------------------------
    '' For 4 or 8 bpp, reallocate the memory to allow space for the
    '' color table (RGBQUAD array).
    ''
    '' The HeapReAlloc function, when reallocating a memory block
    '' to a larger size, even with the HEAP_ZERO_MEMORY flag, will
    '' preserve the contents of the original block.
    '---------------------------------------------------------------

    Select Case bppDib
      Case 4
        pbmi = HeapReAlloc( hHeap, HEAP_ZERO_MEMORY, pbmi, _
                            sizeof(BITMAPINFO) + 16 * sizeof(RGBQUAD) )
      Case 8
        pbmi = HeapReAlloc( hHeap, HEAP_ZERO_MEMORY, pbmi, _
                            sizeof(BITMAPINFO) + 256 * sizeof(RGBQUAD) )
    End Select

    '--------------------------------------------------------------------
    '' Assume the bitmap will not be compressed and set the BI_RGB flag.
    '--------------------------------------------------------------------

    pbmi->bmiHeader.biCompression = BI_RGB

    '--------------------------------------------------------------
    '' Calc the number of bytes for the bitmap image and store the
    '' result in the biSizeImage member. The scan lines must be
    '' DWORD aligned, so the width in bits must be adjusted to a
    '' multiple of 32 by adding 31 and then clearing the lower 5
    '' bits.
    '--------------------------------------------------------------

    i = pbmi->bmiHeader.biBitCount * pbmi->bmiHeader.biWidth
    i += 31
    i And= (Not 31)
    i Shr= 3
    pbmi->bmiHeader.biSizeImage = i * pbmi->bmiHeader.biHeight

    '----------------------------------------------------------------
    '' Calc the horizontal and vertical resolution for the screen in
    '' pixels per meter and store the results in the biXPelsPerMeter
    '' and biYPelsPerMeter members. For index values LOGPIXELSX and
    '' LOGPIXELSY the GetDeviceCaps function returns the resolution
    '' in pixels per logical inch.
    '----------------------------------------------------------------

    i = GetDeviceCaps( hdcScreen, LOGPIXELSX )
    pbmi->bmiHeader.biXPelsPerMeter = i * 39370 \ 1000
    i = GetDeviceCaps( hdcScreen, LOGPIXELSY )
    pbmi->bmiHeader.biYPelsPerMeter = i * 39370 \ 1000

    '-------------------------------------------------
    '' For 4 or 8 bpp set the biClrUsed member to the
    '' correct value, otherwise leave it set to 0.
    '-------------------------------------------------

    Select Case pbmi->bmiHeader.biBitCount
      Case 4
        pbmi->bmiHeader.biClrUsed = 16
      Case 8
        pbmi->bmiHeader.biClrUsed = 256
    End Select

    '-------------------------------------------------
    '' Set the biClrImportant member to 0, indicating
    '' that all of the device colors are important.
    '-------------------------------------------------

    pbmi->bmiHeader.biClrImportant =  0

    '------------------------------------------------
    '' Allocate a buffer to receive the bitmap data.
    '------------------------------------------------

    pbmp = HeapAlloc( hHeap, HEAP_ZERO_MEMORY, _
                      pbmi->bmiHeader.biSizeImage )

    '---------------------------------------------------------------
    '' Call the GetDIBits function to retrieve the bitmap bits from
    '' the DDB and store them, and the synthesized color table, if
    '' present, in the buffer.
    ''
    '' The biClrUsed member of the BITMAPINFOHEADER structure must
    '' be preserved around the call to prevent the function from
    '' setting it to 0.
    '---------------------------------------------------------------

    clrUsed = pbmi->bmiHeader.biClrUsed
    GetDIBits( hdcScreen, hbmp, 0, pbmi->bmiHeader.biHeight, _
               pbmp, pbmi, DIB_RGB_COLORS )
    pbmi->bmiHeader.biClrUsed = clrUsed

    '-------------------
    '' Create the file.
    '-------------------

    hFile = CreateFile( filename, GENERIC_READ Or GENERIC_WRITE, _
                        0, null, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, _
                        null )

    '-----------------------------------------------------
    '' Calculate the size of the file and initialize the
    '' members of the BITMAPFILEHEADER.
    ''
    '' The bfType member must be 'BM' as stored in memory.
    '-----------------------------------------------------

    i = pbmi->bmiHeader.biClrUsed * sizeof(RGBQUAD)
    i += sizeof(BITMAPFILEHEADER)
    i += pbmi->bmiHeader.biSize
    hdr.bfOffBits = i
    i += pbmi->bmiHeader.biSizeImage
    hdr.bfType = &h4d42
    hdr.bfSize = i

    '-----------------------------------------------------
    '' Copy the BITMAPFILEHEADER structure into the file.
    '-----------------------------------------------------

    WriteFile( hFile, @hdr, sizeof(BITMAPFILEHEADER), @i, null )

    '-------------------------------------------------------------
    '' Copy the BITMAPINFOHEADER structure and the RGBQUAD array,
    '' if present, into the file.
    '-------------------------------------------------------------

    i = pbmi->bmiHeader.biClrUsed * sizeof(RGBQUAD)
    i += sizeof(BITMAPINFOHEADER)
    WriteFile( hFile, pbmi, i, @i, null )

    '--------------------------------------
    '' Copy the bitmap bits into the file.
    '--------------------------------------

    WriteFile( hFile, pbmp, pbmi->bmiHeader.biSizeImage, @i, null )

    '------------
    '' Clean up.
    '------------

    ReleaseDC( null, hdcScreen )
    HeapFree( hHeap, 0, pbmi )
    HeapFree( hHeap, 0, pbmp )
    CloseHandle( hFile )

    Return true

End Function
 