Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win


Save clipboard image to black and white bmp file in VBA

Posted on 2011-03-25
Medium Priority
Last Modified: 2012-05-11
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

Question by:duncanb7
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 4
  • 2

Accepted Solution

wellous earned 501 total points
ID: 35218997

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

LVL 45

Assisted Solution

patrickab earned 999 total points
ID: 35221543
Use: mW Snap from:

http://mwsnap.en.softonic.com/ it's free & v good - fast & small files
LVL 13

Author Comment

ID: 35221553
I want  program code, not a software
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

LVL 45

Expert Comment

ID: 35221568
I want  program code, not a software. - GET Mw snAP
LVL 13

Author Comment

ID: 35221575
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 ?
LVL 13

Author Comment

ID: 35221577
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
LVL 45

Assisted Solution

patrickab earned 999 total points
ID: 35222179
to convert it into mono from improving my code above,

nOT MUCH POINT IF YOU CAN DO BETTER with mWSnap. colour alway helps
LVL 45

Expert Comment

ID: 35223861
saftware - software is a better option!!
LVL 13

Author Closing Comment

ID: 35363114
Thanks for your reply

Expert Comment

ID: 35369264
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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes a serious pitfall that can happen when deleting shapes using VBA.
After seeing numerous questions for Dynamic Data Validation I notice that most have used Visual Basic to solve the problem. This suggestion is purely formula based and can be used in multiple rows.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

618 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question