[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 2724
  • 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

Duncan
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
       'ActiveSheet.Paste
       SaveSelectionAsBMP
       
       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)
        CloseClipboard
         
         '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

0
duncanb7
Asked:
duncanb7
  • 4
  • 4
  • 2
3 Solutions
 
wellousCommented:
Hi,

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 bInfo As BITMAPINFO
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
Else
   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


0
 
patrickabCommented:
Use: mW Snap from:

http://mwsnap.en.softonic.com/ it's free & v good - fast & small files
0
 
duncanb7Author Commented:
I want  program code, not a software
0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
patrickabCommented:
I want  program code, not a software. - GET Mw snAP
0
 
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 ?
0
 
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
0
 
patrickabCommented:
to convert it into mono from improving my code above,

nOT MUCH POINT IF YOU CAN DO BETTER with mWSnap. colour alway helps
0
 
patrickabCommented:
saftware - software is a better option!!
0
 
duncanb7Author Commented:
Thanks for your reply
0
 
wellousCommented:
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))))))
0

Featured Post

[Webinar] Cloud and Mobile-First Strategy

Maybe you’ve fully adopted the cloud since the beginning. Or maybe you started with on-prem resources but are pursuing a “cloud and mobile first” strategy. Getting to that end state has its challenges. Discover how to build out a 100% cloud and mobile IT strategy in this webinar.

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