[Webinar] Streamline your web hosting managementRegister Today

  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2769
  • Last Modified:

Save clipboard image to black and white bmp file in VBA

Dear Expert,

I've just done capture a window image and save it to a file like jpeg or gif or bmp format.
Acutally I would like to do image recongizing as text  work so now I think I need to save the image
as small size as possible, how could I save the image file to white and black or monochrome
format in VBA ? I try to change hdc = GetDC(DeskHwnd) to
hdc = GetDC(0)  in sub of SaveSelectionAsBMP() but that  doesn't work. So any suggestion
The second question,  since my image is just 4k byte (if in monchrome format), so I would like
to know how I know the file is compressed or not during file saving with the mono color bmp format.
ANy good website for bmp format study ? So that I can use hex editor to study the file

Please advise

Complete capture window image and save a file 

Function ScreenToClipBoard2()
Dim ActiveHwnd As Long
Dim DeskHwnd As Long
Dim ForegroundHwnd As Long
Dim hdc As Long
Dim hdcMem As Long
Dim rect As rect
Dim junk As Long
Dim fwidth As Long, fheight As Long
Dim hBitmap As Long
    ' Get window handle to Windows and Microsoft Access
    DeskHwnd = GetDesktopWindow()
    ActiveHwnd = GetActiveWindow()
   ' ActiveHwnd = &H1D065C
  ActiveHwnd = &H1208E4
    ForegroundHwnd = GetForegroundWindow()

    ' Get screen coordinates of Active Window
    Call GetWindowRect(ActiveHwnd, rect)
    ' or
    ' Call GetWindowRect(ForegroundHwnd, rect)
    fwidth = rect.Right - rect.Left
    fheight = rect.Bottom - rect.Top
    ' Get the device context of Desktop and allocate memory
    hdc = GetDC(DeskHwnd)
    hdcMem = CreateCompatibleDC(hdc)
    hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
    If hBitmap <> 0 Then
       junk = SelectObject(hdcMem, hBitmap)
       ' Copy the Desktop bitmap to memory location
       ' based on Microsoft Access coordinates.
       junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.Left, _
                     rect.Top, SRCCOPY)
       ' Set up the Clipboard and copy bitmap
       junk = OpenClipboard(DeskHwnd)
       junk = EmptyClipboard()
       junk = SetClipboardData(CF_BITMAP, hBitmap)
      ' Range("A1").Select
       junk = CloseClipboard()
    End If
    ' Clean up handles
    junk = DeleteDC(hdcMem)
    junk = ReleaseDC(DeskHwnd, hdc)
End Function
 Sub SaveSelectionAsBMP()
        Dim oImageIcon As CommandBarControl
        Dim intFaceId As Integer
        Dim IID_IDispatch As GUID
        Dim uPicinfo As uPicDesc
        Dim IPic As IPicture
        Dim hPtr As Long
        Dim FilePathName As Variant
       ' Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        strPictureFile = Application.GetSaveAsFilename("", "JPEG Files (*.jpeg), *.jpeg", , "Save as JPEG")
        If strPictureFile = "False" Then Exit Sub
        OpenClipboard 0
        hPtr = GetClipboardData(CF_BITMAP)
         'Create the interface GUID for the picture
        With IID_IDispatch
            .Data1 = &H7BF80980
            .Data2 = &HBF32
            .Data3 = &H101A
            .Data4(0) = &H8B
            .Data4(1) = &HBB
            .Data4(2) = &H0
            .Data4(3) = &HAA
            .Data4(4) = &H0
            .Data4(5) = &H30
            .Data4(6) = &HC
            .Data4(7) = &HAB
        End With
         ' Fill uPicInfo with necessary parts.
        With uPicinfo
            .Size = Len(uPicinfo) ' Length of structure.
            .Type = PICTYPE_BITMAP ' Type of Picture
            .hPic = hPtr ' Handle to image.
            .hPal = 0 ' Handle to palette (if bitmap).
        End With
         'Create the Picture Object
        OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
         'Save Picture
        stdole.SavePicture IPic, strPictureFile
         'fix the clipboard (it seems to go messed up)
        Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    End Sub

Open in new window

  • 4
  • 4
  • 2
3 Solutions

I found this for you , i hope it's useful :) cheers , Wellous

Here's a procedure for saving a picturebox's image as a black & white bmp file. I finally got back to that old project and figured it out. GetDIBits did the trick.
All white pixels are saved as white. Anything other than white is saved as black. It doesn't do greyscale or dithering, so photos will come out pretty much all black.  This procedure creates a file about 24 times smaller than the SavePicture statement.

Private Sub SavePictureBW(ByVal ctrl As PictureBox, ByVal destfile As String)
Dim hdcMono As Long, hbmpMono As Long, hbmpOld As Long, dxBlt As Long, dyBlt As Long, success As Long
Dim numscans As Long, byteswide As Long, totalbytes As Long, lfilesize As Long
Dim bmpsrc As BITMAP, bmpdst As BITMAP
Dim bitmaparray() As Byte, fileheader() As Byte
Dim ff As Integer

'Object's scalemode must be Pixel.
dxBlt = ctrl.ScaleWidth
dyBlt = ctrl.ScaleHeight

'Create monochrome bitmap from control.
hdcMono = CreateCompatibleDC(0)
hbmpMono = CreateCompatibleBitmap(hdcMono, dxBlt, dyBlt)
success = GetBitmapObject(hbmpMono, Len(bmpsrc), bmpsrc)
hbmpOld = SelectObject(hdcMono, hbmpMono)
success = BitBlt(hdcMono, 0, 0, dxBlt, dyBlt, ctrl.hdc, 0, 0, SRCCOPY)

'Calculate array size needed for bitmap bits (dword aligned)
numscans = dyBlt
by8 = dxBlt / 8
If (dxBlt Mod 8) = 0 And (by8 Mod 4) = 0 Then
   byteswide = by8
   byteswide = (Int(by8) + 4) - (Int(by8) Mod 4)
End If
totalbytes = numscans * byteswide
ReDim bitmaparray(1 To totalbytes)

'Set BITMAPINFO values to pass to GetDIBits function.
With bInfo
   .bmiHeader.biSize = Len(.bmiHeader)
   .bmiHeader.biWidth = bmpsrc.bmWidth
   .bmiHeader.biHeight = bmpsrc.bmHeight
   .bmiHeader.biPlanes = bmpsrc.bmPlanes
   .bmiHeader.biBitCount = bmpsrc.bmBitsPixel
   .bmiHeader.biCompression = BI_RGB
End With

success = GetDIBits(hdcMono, hbmpMono, 0, numscans, bitmaparray(1), bInfo, DIB_RGB_COLORS)

'bitmaparray should now contain bitmap bit data. Now create bitmap file header.
ReDim fileheader(1 To &H3E)
fileheader(1) = &H42 'B
fileheader(2) = &H4D 'M
lfilesize = UBound(fileheader) + UBound(bitmaparray)
fileheader(3) = lfilesize And 255
fileheader(4) = (lfilesize \ 256) And 255
fileheader(5) = (lfilesize \ 65536) And 255
fileheader(6) = (lfilesize \ 16777216) And 255
fileheader(11) = &H3E 'offset
fileheader(15) = &H28 'size of bitmapinfoheader
fileheader(19) = dxBlt And 255
fileheader(20) = (dxBlt \ 256) And 255
fileheader(21) = (dxBlt \ 65536) And 255
fileheader(22) = (dxBlt \ 16777216) And 255
fileheader(23) = dyBlt And 255
fileheader(24) = (dyBlt \ 256) And 255
fileheader(25) = (dyBlt \ 65536) And 255
fileheader(26) = (dyBlt \ 16777216) And 255
fileheader(27) = 1
fileheader(29) = 1
fileheader(35) = UBound(bitmaparray) And 255
fileheader(36) = (UBound(bitmaparray) \ 256) And 255
fileheader(37) = (UBound(bitmaparray) \ 65536) And 255
fileheader(38) = (UBound(bitmaparray) \ 16777216) And 255
fileheader(47) = 2
fileheader(51) = 2
fileheader(59) = &HFF
fileheader(60) = &HFF
fileheader(61) = &HFF

ff = FreeFile
Open destfile For Binary Access Write As #ff
   Put #ff, , fileheader
   Put #ff, , bitmaparray
Close #ff

' Clean up
Call SelectObject(hdcMono, hbmpOld)
Call DeleteDC(hdcMono)
Call DeleteObject(hbmpMono)
End Sub

Use: mW Snap from:

http://mwsnap.en.softonic.com/ it's free & v good - fast & small files
duncanb7Author Commented:
I want  program code, not a software
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

I want  program code, not a software. - GET Mw snAP
duncanb7Author Commented:
Dear Wellous,

What is  Dim bmpsrc As BITMAP, bmpdst As BITMAP
Dim bInfo As BITMAPINFO, and it  have error in Excel 2003 VBA editor.
Is your code running at  VB6 ?

Do you have the code for VBA ?
duncanb7Author Commented:
Dear patrickab,
Just a caputre saftware ?
I have already done the capture  image part in VBA, just wnat
to convert it into mono from improving my code above
to convert it into mono from improving my code above,

nOT MUCH POINT IF YOU CAN DO BETTER with mWSnap. colour alway helps
saftware - software is a better option!!
duncanb7Author Commented:
Thanks for your reply
Dear Duncanb,

I am sorry i was away.. pls find my answer to your questions, and thanks alot for the grade :)
What is  Dim bmpsrc As BITMAP, bmpdst As BITMAP ::::: (((((it's the bmp source))))
Dim bInfo As BITMAPINFO, and it  have error in Excel 2003 VBA editor :::::::::: (((( Yes, i needs a modifications/ improvement )))))
Is your code running at  VB6 ? ::::::::::::::::(((((( No, this code was written in C - the big mam ;-)  )))))))

Do you have the code for VBA ?  :::::::::: ((((No, this is what i could find at the BMP records))))))

Featured Post

The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

  • 4
  • 4
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now