VBA后台窗口截图代码，请帮完善下

shofing

网上找到了个VBA后台窗口截图代码，测试没有成功，请高手请帮完善下，感激





引用地址 http://wolfccb.com/?p=296

以下是代码

1. 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
   
2.     'Dump the screen of specified form and save to clipboard.
   
3.     'hWnd is the handle of target form, croptop/cropbottom/cropleft/cropright are pixels to crop, 0 by default means no crop.
   
4.     'Return string message
   
5.    
   
6.     Dim UserFormHwnd As Long, DeskHwnd As Long
   
7.     Dim hdc As Long
   
8.     Dim hdcMem, hdcMemc As Long
   
9.     Dim hBitmap, hBitmapc As Long
   
10.     Dim rect As RECT_Type
    
11.     Dim retval As Long
    
12.     Dim fwidth As Long, fheight As Long
    
13.     Dim isCrop As Boolean
    
14. 
    
15.     If croptop < 0 Or cropbottom < 0 Or cropleft < 0 Or cropright < 0 Then
    
16.         ScreenDump = "0-Wrong parameter"
    
17.         Exit Function
    
18.     End If
    
19.    
    
20.     If croptop > 0 Or cropbottom > 0 Or cropleft > 0 Or cropright > 0 Then
    
21.         isCrop = True
    
22.     End If
    
23.    
    
24.     ' Get window handle
    
25.     DeskHwnd = GetDesktopWindow()
    
26.     UserFormHwnd = hWnd
    
27.    
    
28.     ' Get screen coordinates
    
29.     Call GetWindowRect(UserFormHwnd, rect)
    
30. 
    
31.     fwidth = rect.right - rect.left
    
32.     fheight = rect.bottom - rect.top
    
33. 
    
34.     ' Get the device context of Desktop and allocate memory
    
35.     hdc = GetDC(DeskHwnd)
    
36.     hdcMem = CreateCompatibleDC(hdc)
    
37.     hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
    
38. 
    
39.     If hBitmap <> 0 Then
    
40.         
    
41.         retval = SelectObject(hdcMem, hBitmap)
    
42. 
    
43.         'Redraw window before capture
    
44.         RedrawWindow UserFormHwnd, ByVal 0, ByVal 0, RDW_INVALIDATE Or RDW_ALLCHILDREN Or RDW_UPDATENOW
    
45.         
    
46.         ' Copy bitmap to memory location
    
47.         
    
48.         retval = PrintWindow(UserFormHwnd, hdcMem, 0)
    
49. 
    
50.         'Crop image
    
51.         If isCrop = True Then
    
52.             
    
53.             fwidth = fwidth - cropleft - cropright
    
54.             fheight = fheight - croptop - cropbottom
    
55.             
    
56.             'Allocate memory for cropped image
    
57.             hdcMemc = CreateCompatibleDC(hdc)
    
58.             hBitmapc = CreateCompatibleBitmap(hdc, fwidth, fheight)
    
59.             retval = SelectObject(hdcMemc, hBitmapc)
    
60.             
    
61.             'Crop
    
62.             retval = BitBlt(hdcMemc, 0, 0, fwidth, fheight, hdcMem, cropleft, croptop, SRCCOPY)
    
63. 
    
64.             'Set up the Clipboard and copy bitmap
    
65.             retval = OpenClipboard(DeskHwnd)
    
66.             retval = EmptyClipboard()
    
67.             retval = SetClipboardData(CF_BITMAP, hBitmapc)
    
68.             retval = CloseClipboard()
    
69.             
    
70.             'Clean up
    
71.             retval = DeleteDC(hdcMemc)
    
72.             retval = DeleteObject(hBitmapc)
    
73.             
    
74.         Else
    
75.             
    
76.             'Set up the Clipboard and copy bitmap
    
77.             retval = OpenClipboard(DeskHwnd)
    
78.             retval = EmptyClipboard()
    
79.             retval = SetClipboardData(CF_BITMAP, hBitmap)
    
80.             retval = CloseClipboard()
    
81.             
    
82.         End If
    
83. 
    
84.         ScreenDump = "1-Success"
    
85.         
    
86.     Else
    
87.    
    
88.         ScreenDump = "2-No bitmap"
    
89.    
    
90.     End If
    
91. 
    
92.     ' Clean up
    
93.     retval = DeleteDC(hdcMem)
    
94.     retval = ReleaseDC(DeskHwnd, hdc)
    
95.     retval = DeleteObject(hBitmap)
    
96. 
    
97. End Function
    
98. 
    

复制代码