按句柄及指定区域后台截图

Option Explicit
Private Const BI_RGB = 0& '自定义值
Private Const DIB_RGB_COLORS = 0 '自定义值
Private Const OBJ_BITMAP As Long = 7 '自定义值

Private Type RECT '自定义类型
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type BITMAPINFOHEADER '自定义类型
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD '自定义值
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
'Gray=R0.3+G0.59+B*0.11’灰度化公式
End Type
Private Type BITMAPINFO '自定义值
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type

Private Declare Function FindWindow Lib “user32” Alias “FindWindowA” _
(ByVal lpclassname As String, ByVal lpWindowName As String) As Long '设类型或标题找窗体句柄
Private Declare Function GetForegroundWindow Lib “user32” () As Long '声明返回当前窗口的句柄
Private Declare Function GetCurrentObject Lib “gdi32.dll” _
(ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Declare Function GetDIBits Lib “gdi32” _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetWindowRect Lib “user32.dll” _
(ByVal hwnd As Long, ByRef lpRect As RECT) As Long

Private Declare Function StretchBlt Lib “gdi32” _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long
Private Declare Function PrintWindow Lib “user32” _
(ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long

Private Declare Function SelectObject Lib “gdi32” _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function GetDC Lib “user32” (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib “gdi32” (ByVal hdc As Long) As Long

Private Declare Function DeleteDC Lib “gdi32” (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib “gdi32” _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetParent Lib “user32” (ByVal hwnd As Long) As Long
Private Declare Function FindWindowEx Lib “user32” Alias “FindWindowExA” (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Sub Sleep Lib “kernel32.dll” (ByVal dwMilliseconds As Long)
Private Declare Function MsgBoxEx Lib “user32” Alias “MessageBoxTimeoutA” _
(ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As _
VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
Private Function 初始化24位BMP信息头(x_w As Long, y_h As Long, bi24BitInfo As BITMAPINFO, BMPbyte() As Byte) 'As BITMAPINFO
'Dim bi24BitInfo As BITMAPINFO
'Private aBytes() As Byte
ReDim BMPbyte(0 To 53) As Byte
Dim w As Long, h As Long, r As Long, Bmplen As Long
w = x_w: h = y_h
If w Mod 4 > 0 Then
w = w + 4 - (w Mod 4)
End If ’
With bi24BitInfo.bmiHeader '初始化24位BMP信息头
.biBitCount = 24
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = w
.biHeight = h
.biSizeImage = 3 * (w) * (h)
End With
Bmplen = (w) * (h) * 3 + 54
'以下初始化BMP文件头信息到字节数组文件头 + 位图信息 + 位图像素数据
BMPbyte(0) = 66
BMPbyte(1) = 77
CopyMemory BMPbyte(2), Bmplen, 4 'bfSize As Long文件长 2-5
CopyMemory BMPbyte(6), 0, 4 'bfReserved1,2 As Integer 6-9
BMPbyte(8) = 0
BMPbyte(9) = 0
CopyMemory BMPbyte(10), 54, 4 'bfOffBits As Long 10-13
BMPbyte(12) = 0
BMPbyte(13) = 0
''以上文件头****************************************
CopyMemory BMPbyte(14), bi24BitInfo.bmiHeader.biSize, 4 'biSize As Long 14-17
CopyMemory BMPbyte(18), bi24BitInfo.bmiHeader.biWidth, 4 'biWidth As Long 18-21
CopyMemory BMPbyte(22), bi24BitInfo.bmiHeader.biHeight, 4 'biHeight As Long 22-25
CopyMemory BMPbyte(26), bi24BitInfo.bmiHeader.biPlanes, 2 'biPlanes As Integer 26-27
CopyMemory BMPbyte(28), 24, 2 'biBitCount As Integer 28-29,真彩24位色
CopyMemory BMPbyte(30), bi24BitInfo.bmiHeader.biCompression, 4 'biCompression As Long 30-33
CopyMemory BMPbyte(34), bi24BitInfo.bmiHeader.biSizeImage, 4 'biSizeImage As Long 34-37
'CopyMemory BMPbyte(38), bi24BitInfo.bmiHeader.biXPelsPerMeter, 4 'biXPelsPerMeter As Long 38-41
For r = 38 To 53
BMPbyte® = 0
Next
''以上写位图信息******************************************
'On Error Resume Next
End Function
Private Function 定义位图信息(x_w As Long, y_h As Long, bi24BitInfo As BITMAPINFO, BMPbyte() As Byte) '*文件头 + 位图信息 + 位图像素数据
ReDim BMPbyte(0 To 53) As Byte
Dim Bmplen As Long, i As Long
If x_w Mod 4 > 0 Then x_w = x_w + 4 - x_w Mod 4
If x_w = 0 Or y_h = 0 Then
MsgBoxEx GetForegroundWindow, "x_w 或 y_h 为零，没有面积，退出, ", _
“执行情况监测，自动关闭”, 0, 1, 3000 '1000毫秒，显示时间
Exit Function
End If
With bi24BitInfo.bmiHeader '初始化24位BMP信息头
.biBitCount = 24
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = x_w
.biHeight = y_h
.biSizeImage = 3 * x_w * y_h
End With
Bmplen = x_w * y_h * 3 + 54
'******以下初始化BMP文件头信息到字节数组文件头 + 位图信息 + 位图像素数据
BMPbyte(0) = 66
BMPbyte(1) = 77
CopyMemory BMPbyte(2), Bmplen, 4 'bfSize As Long文件长 2-5
CopyMemory BMPbyte(6), 0, 4 'bfReserved1,2 As Integer 6-9
BMPbyte(8) = 0
BMPbyte(9) = 0
CopyMemory BMPbyte(10), 54, 4 'bfOffBits As Long 10-13
BMPbyte(12) = 0
BMPbyte(13) = 0
CopyMemory BMPbyte(14), bi24BitInfo.bmiHeader.biSize, 4 'biSize As Long 14-17
CopyMemory BMPbyte(18), bi24BitInfo.bmiHeader.biWidth, 4 'biWidth As Long 18-21
CopyMemory BMPbyte(22), bi24BitInfo.bmiHeader.biHeight, 4 'biHeight As Long 22-25
CopyMemory BMPbyte(26), bi24BitInfo.bmiHeader.biPlanes, 2 'biPlanes As Integer 26-27
CopyMemory BMPbyte(28), 24, 2 'biBitCount As Integer 28-29,真彩24位色
CopyMemory BMPbyte(30), bi24BitInfo.bmiHeader.biCompression, 4 'biCompression As Long 30-33
CopyMemory BMPbyte(34), bi24BitInfo.bmiHeader.biSizeImage, 4 'biSizeImage As Long 34-37
For i = 38 To 53
BMPbyte(i) = 0
Next
End Function
Public Function 按句柄及指定区域后台截图(ByVal hwnd As Long, PathFile As String, _
x_q As Long, y_q As Long, x_w As Long, y_h As Long) As Long
'后台截图，参数1要截图的窗口句柄，参数2要保存的文件路径
'x_q指定起点, y_q 指定起点, x_w 指定宽, y_h指定高
Dim bi24BitInfo As BITMAPINFO
Dim BMPbyte() As Byte
Dim rc As RECT
Dim w As Long, h As Long, i As Long
Dim hdc As Long, mhDC As Long, mBmp As Long, L_n_1 As Long, new_hwnd As Long
Dim mhDC_1 As Long, mBmp_1 As Long, new_hwnd_1 As Long
If hwnd = 0 Then
MsgBoxEx GetForegroundWindow, "句柄 为零，，退出, ", _
“执行情况监测，自动关闭”, 0, 1, 3000 '1000毫秒，显示时间
Exit Function
End If
On Error Resume Next
GetWindowRect hwnd, rc '得到句柄窗口的矩形位置，大小
If (rc.Right - rc.Left) Mod 4 > 0 Then
w = rc.Right - rc.Left + 4 - ((rc.Right - rc.Left) Mod 4)
Else
w = rc.Right - rc.Left
End If
h = rc.Bottom - rc.Top
If x_q + x_w > w Or y_q + y_h > h Then
MsgBoxEx GetForegroundWindow, "指定区域超出原图退出, ", _
“执行情况监测，自动关闭”, 0, 1, 3000 '1000毫秒，显示时间
Exit Function
End If

hdc = GetDC(hwnd) '得到指定窗口句柄DC
mhDC = CreateCompatibleDC(hdc) '创建内存DC
mBmp = CreateCompatibleBitmap(hdc, w, h)
L_n_1 = SelectObject(mhDC, mBmp) '把窗口位图选入内存DC
PrintWindow hwnd, mhDC, 0 '把窗口截取保存到内存DC中，
mhDC_1 = CreateCompatibleDC(hdc) '创建内存DC
mBmp_1 = CreateCompatibleBitmap(hdc, x_w, y_h)
L_n_1 = SelectObject(mhDC_1, mBmp_1) '把窗口位图选入内存DC
Call StretchBlt(mhDC_1, 0, 0, x_w, y_h, _
mhDC, x_q, y_q, x_w, y_h, SRCCOPY)
ReDim aBytes(0 To x_w * y_h * 3 - 1) As Byte
new_hwnd = GetCurrentObject(mhDC_1, OBJ_BITMAP) '用于获得指定类型的当前选定对象hwnd
Call 定义位图信息(x_w, y_h, bi24BitInfo, BMPbyte)
GetDIBits mhDC_1, new_hwnd, 0, y_h, aBytes(0), bi24BitInfo, DIB_RGB_COLORS
'*************》》》》》》》》》》》》》》》》》
Open PathFile For Binary As #1
Put #1, , BMPbyte()
Put #1, , aBytes()
Close #1
DeleteObject new_hwnd
DeleteObject L_n_1
DeleteObject mBmp
DeleteDC mhDC
DeleteDC hdc
DeleteObject mBmp_1
DeleteDC mhDC_1
Erase aBytes
Erase BMPbyte
'PathFile = “D:” & i & “.JPG”
End Function
Private Sub 示例_Click()
Dim hwnd As Long
hwnd = GetForegroundWindow '当前活动窗口
Dim PathFile As String
PathFile = “D:\按句柄后台截图_示例23.JPG”
Call 按句柄及指定区域后台截图(hwnd, PathFile, 50, 50, 200, 300)
End Sub