Solved

Capture Window Image in VBA

Posted on 2011-03-25
4
2,902 Views
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

http://www.experts-exchange.com/OS/Microsoft_Operating_Systems/Windows/XP/Q_22959939.html?sfQueryTermInfo=1+10+30+captur+imag+screen+vba

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

Duncan
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
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    
    '---------------------------------------------------
    ' 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 http://msdn2.microsoft.com/en-us/library/ms533272.aspx
            Exit Sub
        End If
    Else
        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)
                Else
                    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
                '---------------------------------------------
                Range("A1").Select
                ActiveSheet.Paste
                
                '---------------------------------------------
                ' 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
 
Stop
 
End Sub

Open in new window

0
Comment
Question by:duncanb7
  • 2
  • 2
4 Comments
 
LVL 32

Accepted Solution

by:
Erick37 earned 500 total points
Comment Utility
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?
0
 
LVL 13

Author Comment

by:duncanb7
Comment Utility
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,

Thank

Duncan
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
 
LVL 32

Expert Comment

by:Erick37
Comment Utility
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.
0
 
LVL 13

Author Closing Comment

by:duncanb7
Comment Utility
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
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

771 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

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now