Creating 24 bits BMP-file

[Semen Matusovski]

Tested under Win2000. If doesn't work under another OSes, pls, let me know.

Like sample, this code takes central part of desktop window (60% width / height)

   #Compile Exe
   #Register None
   #Dim All
   #Include "Win32Api.Inc"
   
   $BmpFile = "C:\Bmp24.Bmp"
   
   '====================================================
   Function CreateTrueColorBmpFile (FileBmp As String, hWnd As Long, rc As RECT) As Long
      Local f As Long, hDC As Long, hMemDC As Long
      Local hMemBmp As Long, bm As BITMAP, bmi As BITMAPINFO
      Local lpBITMAPFILEHEADER As BITMAPFILEHEADER, lpBITMAPINFOHEADER As BITMAPINFOHEADER
      
      hDC = GetDC(hWnd): hMemDC = CreateCompatibleDC (hDC)
      
      bmi.bmiHeader.biSize = SizeOf(bmi.bmiHeader)
      bmi.bmiHeader.biWidth = (rc.nRight - rc.nLeft)
      bmi.bmiHeader.biHeight = (rc.nBottom - rc.nTop)
      bmi.bmiHeader.biPlanes = 1
      bmi.bmiHeader.biBitCount = 24
      bmi.bmiHeader.biCompression = %BI_RGB
      hMemBmp = CreateDIBSection(hMemDC, bmi, %DIB_RGB_COLORS, 0, 0, 0)
      GlobalLock hMemBmp
      SelectObject hMemDC, hMemBmp
      GetObject hMemBmp, SizeOf(bm), bm
      BitBlt hMemDC, 0, 0, bm.bmWidth, bm.bmHeight, hDC, rc.nLeft, rc.nTop, %SRCCOPY
      
      lpBITMAPFILEHEADER.bfType = Cvi("BM")
      lpBITMAPFILEHEADER.bfSize = Len(lpBITMAPFILEHEADER) + Len(lpBITMAPINFOHEADER) + _
         bm.bmWidthBytes * bm.bmHeight
      lpBITMAPFILEHEADER.bfOffBits = 54
      lpBITMAPINFOHEADER.biSize = 40
      lpBITMAPINFOHEADER.biWidth = bm.bmWidth
      lpBITMAPINFOHEADER.biHeight = bm.bmHeight
      lpBITMAPINFOHEADER.biPlanes = 1
      lpBITMAPINFOHEADER.biBitCount = 24
      lpBITMAPINFOHEADER.biSizeImage = 54& + bm.bmWidthBytes * bm.bmHeight
      
      f = FreeFile: Open FileBmp For Output As #f
      Print #f, lpBITMAPFILEHEADER lpBITMAPINFOHEADER _
          Peek$(bm.bmBits, bm.bmWidthBytes * bm.bmHeight);: Close #f
 
      ReleaseDC hWnd, hDC: DeleteDC hMemDC: GlobalUnlock hMemBmp: DeleteObject hMemBmp
   End Function
   
   '==============================================
   CallBack Function ButProc
      Local rc As RECT
      rc.nLeft = 0.2 * GetSystemMetrics(%SM_CXSCREEN): rc.nRight = 4 * rc.nLeft
      rc.nTop = 0.2 * GetSystemMetrics(%SM_CYSCREEN): rc.nBottom = 4 * rc.nTop
      CreateTrueColorBmpFile $BmpFile, GetDesktopWindow, rc
   End Function
   
   Function PbMain
      Local hDlg As Long
      Dialog New 0, "Polus", ,, 200, 70, %WS_SYSMENU To hDlg
      Control Add TextBox, hDlg, 101, "", 5, 5, 190, 12
      Control Add Button, hDlg, 102, "Copy client area", 30, 30, 140, 15 Call ButProc
      Dialog Show Modal hDlg
   End Function

------------------

[Aisin Geuru Suen Yue]

Work on Windows98SE!


------------------