Save clipboard image to black and white bmp file in VBA

Posted on 2011-03-25
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
  • 4
  • 4
  • 2

Accepted Solution

wellous earned 167 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 333 total points
ID: 35221543
Use: mW Snap from: it's free & v good - fast & small files
LVL 13

Author Comment

ID: 35221553
I want  program code, not a software
Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

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 333 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

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

830 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