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

以上。
旧调重弹的老狼