VBA后台窗口截图

这段时间做了很多VBA外挂用来抓取网页上的数据保存到excel（用Webbrowser控件），现在又遇到一个网页截图保存的需求。微软kb210108的代码只能截取当前活动窗口，不能后台工作，也不能有其它窗口覆盖在上面。我把它扩展成了可截取任意指定的窗口，可以后台截图，不怕覆盖的版本。在Win7下即使最小化也可以截屏，XP下需要把待截图的窗口做成showmodal，但即使这样XP也要在截图时避免使用显示桌面，否则截出来的是黑屏。

顺便做了按指定尺寸剪切图像的参数。截屏结果保存到剪贴板，可以通过网上的CliptoJPG VB代码方便地保存到JPG文件。

如果VBA的Webbrowser也支持DrawToBitmap方法，我才不用费这个劲……另，听说DrawToBitmap有很多bug。

Function ScreenDump(ByVal hWnd As Long, Optional ByVal croptop As Integer = 0, Optional ByVal cropbottom As Integer = 0, Optional ByVal cropleft As Integer = 0, Optional ByVal cropright As Integer = 0) As String
    'Dump the screen of specified form and save to clipboard.
    'hWnd is the handle of target form, croptop/cropbottom/cropleft/cropright are pixels to crop, 0 by default means no crop.
    'Return string message
     
    Dim UserFormHwnd As Long, DeskHwnd As Long
    Dim hdc As Long
    Dim hdcMem, hdcMemc As Long
    Dim hBitmap, hBitmapc As Long
    Dim rect As RECT_Type
    Dim retval As Long
    Dim fwidth As Long, fheight As Long
    Dim isCrop As Boolean
 
    If croptop < 0 Or cropbottom < 0 Or cropleft < 0 Or cropright < 0 Then
        ScreenDump = "0-Wrong parameter"
        Exit Function
    End If
     
    If croptop > 0 Or cropbottom > 0 Or cropleft > 0 Or cropright > 0 Then
        isCrop = True
    End If
     
    ' Get window handle
    DeskHwnd = GetDesktopWindow()
    UserFormHwnd = hWnd
     
    ' Get screen coordinates
    Call GetWindowRect(UserFormHwnd, 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
         
        retval = SelectObject(hdcMem, hBitmap)
 
        'Redraw window before capture
        RedrawWindow UserFormHwnd, ByVal 0, ByVal 0, RDW_INVALIDATE Or RDW_ALLCHILDREN Or RDW_UPDATENOW
         
        ' Copy bitmap to memory location
         
        retval = PrintWindow(UserFormHwnd, hdcMem, 0)
 
        'Crop image
        If isCrop = True Then
             
            fwidth = fwidth - cropleft - cropright
            fheight = fheight - croptop - cropbottom
             
            'Allocate memory for cropped image
            hdcMemc = CreateCompatibleDC(hdc)
            hBitmapc = CreateCompatibleBitmap(hdc, fwidth, fheight)
            retval = SelectObject(hdcMemc, hBitmapc)
             
            'Crop
            retval = BitBlt(hdcMemc, 0, 0, fwidth, fheight, hdcMem, cropleft, croptop, SRCCOPY)
 
            'Set up the Clipboard and copy bitmap
            retval = OpenClipboard(DeskHwnd)
            retval = EmptyClipboard()
            retval = SetClipboardData(CF_BITMAP, hBitmapc)
            retval = CloseClipboard()
             
            'Clean up
            retval = DeleteDC(hdcMemc)
            retval = DeleteObject(hBitmapc)
             
        Else
             
            'Set up the Clipboard and copy bitmap
            retval = OpenClipboard(DeskHwnd)
            retval = EmptyClipboard()
            retval = SetClipboardData(CF_BITMAP, hBitmap)
            retval = CloseClipboard()
             
        End If
 
        ScreenDump = "1-Success"
         
    Else
     
        ScreenDump = "2-No bitmap"
     
    End If
 
    ' Clean up
    retval = DeleteDC(hdcMem)
    retval = ReleaseDC(DeskHwnd, hdc)
    retval = DeleteObject(hBitmap)
 
End Function

以上。
旧调重弹的老狼

《VBA后台窗口截图》上有1条评论

  1. 不知道是什么原因找到了老狼的这个狼窝，我想老狼应该也是年纪很大的叔叔了吧

评论已关闭。