Capture Window Image in VBA

Posted on 2011-03-25
Last Modified: 2012-05-11
Dear Expert,

I am trying to use Excel2003 VBA to capture a Window screen with its hwnd from the code provided at this website

And the code running is okay but when I step run it by (F8 press) and I found the VBA never going pass to
the code area at " If lColor = 14540253 Then" so there is no any bitBlt() and OpenClipboard() activate
Why it is set lcolor=1450253, what is that meaning ? I always get  lcolor=-1 whatever x and y is

And I found it should set
For x = Rect.Left To Rect.Right
        For y = Rect.Top To Rect.Bottom

Instead of
For x =0 To fheight-1
        For y =0 To fwidth-1

]in order to locate exact position of the image  to be captured, Even wth those change, I'm still not be able
to get the image to show me at Range("A1"). The image at Range("A1") is blank.  Please advise any mistake I made  and I would like  to ask Two more question.

1- Why it is set  86,21  at  BitBlt hDCmem2, 0, 0, 86, 21, hDCmem, x, y, SRCCOPY, what is that for
2- How can I save the image at clipboard to a file name as image.jpeg or image.bmp ?

Please advise

Private Sub ScreenToClipBoard()
Dim bHwnd As Long
Dim fwidth As Long
Dim fheight As Long
Dim hBitMap As Long
Dim hBitMap2 As Long
Dim hDC As Long
Dim hDCmem As Long
Dim hDCmem2 As Long
Dim lColor As Long
Dim junk As Long
Dim Rect As Rect
Dim x As Long
Dim y As Long
    bHwnd = FindWindow(vbNullString, "Yahoo!-Windows Internet Explorer")  ' Find Handle for IE
    If bHwnd = 0 Then
        MsgBox ("Did not find the Window with the title of:" & vbCrLf & vbCrLf & _
                """"  & """" & vbCrLf & vbCrLf & _
                "Error number=" & Err.LastDllError)
        Exit Sub
    End If
    junk = SetForegroundWindow(bHwnd)   ' Set this handle/Window as the Foreground Window.
    If junk = 0 Then                    ' A zero return code indicates failure
        MsgBox ("Unable to Set IE as the foreground Window.")
        Exit Sub
    End If
    ' There will be some lag before this window is actually in the foreground, so, give it a
    ' little CPU to move it to the front
    ' Get screen coordinates of the browser window
    Call GetWindowRect(bHwnd, Rect)
    fwidth = Rect.Right - Rect.Left         ' Calculate Width of Window
    fheight = Rect.Bottom - Rect.Top        ' Calculate Height of Window
    ' Get a handle to the browser window
    hDC = GetDC(bHwnd)                      ' Get 'Device Context' for IE window.
    ' GetPixel only works if the hDC and the bitmap have been selected with SelectObject
    ' So, create a compatible bitmap and select it.
    hDCmem = CreateCompatibleDC(hDC)
    hBitMap = CreateCompatibleBitmap(hDC, fwidth, fheight)
    ' Not sure if this should be before or after the SelectObject
    'BitBlt hDCmem, 0, 0, fwidth, fheight, hDC, 0, 0, SRCCOPY
    If hBitMap <> 0 Then
        junk = SelectObject(hDCmem, hBitMap)
        If junk = 0 Then                        ' In my testing I always get a zero
            MsgBox ("Unable to SelectObject")   ' See
            Exit Sub
        End If
        MsgBox "Could NOT create a memory bitmap"
        Exit Sub
    End If
    ' Not sure if this should be before or after the SelectObject
    BitBlt hDCmem, 0, 0, fwidth, fheight, hDC, 0, 0, SRCCOPY
    ' Now create a hDC and bitmap for the final result bitmap.
    hDCmem2 = CreateCompatibleDC(hDC)
    hBitMap2 = CreateCompatibleBitmap(hDC, 86, 21)
    ' Search the browser window looking for the backcolor
    ' of the security code image
    For x = 0 To fheight - 1
        For y = 0 To fwidth - 1
            lColor = GetPixel(hDCmem, x, y)
            If lColor = 14540253 Then   '****************Problem is here, 
                ' Once the security code is found, prepare to copy it
                ' to another memory resident bitmap
                If hBitMap2 <> 0 Then
                    junk = SelectObject(hDCmem2, hBitMap2)
                    MsgBox ("Could NOT create memory bitmap")
                    Exit Sub
                End If
                BitBlt hDCmem2, 0, 0, 86, 21, hDCmem, x, y, SRCCOPY
                ' Set up the Clipboard and copy memory resident bitmap to it
                junk = OpenClipboard(bHwnd)
                junk = EmptyClipboard()
                junk = SetClipboardData(CF_BITMAP, hBitMap2)
                junk = CloseClipboard()
                ' Optionally, paste the clipboard contents into a cell on the spreadsheet
                ' Clean up handles
                junk = DeleteObject(hBitMap)
                junk = DeleteObject(hBitMap2)
                junk = DeleteDC(hDCmem)
                junk = DeleteDC(hDCmem2)
                junk = ReleaseDC(bHwnd, hDC)
            End If
        Next y
    Next x
End Sub

Open in new window

Question by:duncanb7
  • 2
  • 2
LVL 32

Accepted Solution

Erick37 earned 500 total points
ID: 35216215
It looks like the code you copied is looking for a specific region of the screen and is located by looking at the color of the pixels.

"If lColor = 1450253" is testing the pixel color for that exact color, which may not exist on the page you are looking at.  The color -1 is white and 0 would  be black.  Try using 0 and you may see it working somewhat better.  If you are looking to capture the entire screen, then the code you are looking at is not suitable.

Are you looking to save the whole IE window to file?
LVL 13

Author Comment

ID: 35216389
Yes, you are correct, finally I complet to capture the whole window image and save it into file .
Another question, could I covert the image as text format, since image is number but in image jpeg or gif format.?
So I would like to detect the number in the image to do some VBA code controle. If the image can converted to
text 1,2,3,4 that will be easy to VBA code controls
For example, when the image number is 1 then go to  function example in VBA ...Is it possible,


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

LVL 32

Expert Comment

ID: 35216456
Not sure I understand the question.  You want to scan the picture for numbers, like character recognition?  If so, that is not something I have done before, and not something I have seen done in VBA.
LVL 13

Author Closing Comment

ID: 35216743
Thanks for your reply,

Acutally, there is a lot image
recognition software in web but
I just convert several number so
I beleive I can do it by myself in
VBA if I understand the structure of
bit map

Featured Post

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

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

Suggested Solutions

Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.

810 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