Option Explicit
'====================================================
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 SetDIBits Lib "gdi32" (ByVal HDC 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 Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
'左鍵單擊
'====================================================
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '獲取句柄
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long '獲取圖片資料
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal HDC As Long) As Long '釋放DC
Private Declare Function CreateCompatibleDC 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 Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal HDC As Long, ByVal hObject As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
'顏色表
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbAlpha As Byte '透明通道
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 BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
'圖片檔案頭
Dim BI As BITMAPINFO
Dim BI1 As BITMAPINFO
Dim PP As New Form1
'在圖片1中查找圖片2，是否找出全部
Public Function NFindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, Fileurl As String)
Dim P2 As Picture, P2W, P2H, P2Handle
Set P2 = LoadPicture(Fileurl)
P2W = P2.Width
P2H = P2.Height
P2Handle = P2.Handle
Dim W As Long, H As Long, i As Long, j As Long
Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long
Dim zPic() As Byte, fPic() As Byte
Dim R As Byte, G As Byte, b As Byte
'1 獲得圖片2資料
W2 = Form1.ScaleX(P2W, vbHimetric, vbPixels)
H2 = Form1.ScaleY(P2H, 8, 3)
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = W2
.biHeight = -H2
.biBitCount = 32
.biPlanes = 1
End With
ReDim zPic(3, W2 - 1, H2 - 1)
i = GetDIBits(Form1.HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
Set P2 = Nothing
'Debug.Print I
'如果在這里處理一下，影像大的話，可能會快一點。
'2 獲得圖片1資料
W = Right
H = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
For J2 = 0 To H2 - 2 '回圈判斷小圖片
For I2 = 0 To W2 - 2
PP.PSet (I2, J2), RGB(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))
Next I2
Next J2
PP.Refresh
ReDim fPic(3, W - 1, H - 1)
Dim hBMPhDC
Dim hDCmem As Long
Dim Pic1Handle As Long
Dim hBmpPrev As Long
hBMPhDC = GetDC(0)
'常規抓圖代碼，得到一個hBmp：
hDCmem = CreateCompatibleDC(hBMPhDC)
Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
'SelectObject hDCmem, hBmpPrev
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
'Debug.Print I
'分析查找
For j = 0 To H - H2 - 1
VBA.DoEvents
For i = 0 To W - W2 - 1
For J2 = 0 To H2 - 2 '回圈判斷小圖片
For I2 = 0 To W2 - 2
If fPic(2, i + I2, j + J2) <> zPic(2, I2, J2) Then GoTo ExitLine: 'R
If fPic(1, i + I2, j + J2) <> zPic(1, I2, J2) Then GoTo ExitLine: 'G
If fPic(0, i + I2, j + J2) <> zPic(0, I2, J2) Then GoTo ExitLine: 'B
Next I2
Next J2
'Debug.Print "發現:", I, J
NFindPic = i & "," & j
ExitLine:
Next i
Next j
'獲得當前游標的坐標。
'GetCursorPos moubegin
'mousestep = moubegin
'滑鼠移到
End Function
這是一段比較簡單全屏比較找圖的vb代碼，經過測驗，找一兩張圖沒什么問題，但是多找幾張后就找不到了，鍵盤截屏后
粘貼到畫圖板發現是黑白的，多截幾次出現剪貼板錯誤，本人技術有限，檢查了多遍代碼找不出問題，請各位大俠幫忙看看
是哪里出問題了。
下面是多次找圖后鍵盤截屏的圖片
uj5u.com熱心網友回復：
SelectObject hDCmem, hBmpPrev這句代碼不能注釋掉吧！！！
你把它注釋掉了之后，多次執行，分造成 GDI 資源不能正確釋放，
然后跟著就會導致你的程式不能正常創建新的GDI物件。
你要把這兩句代碼：
SelectObject hDCmem, hBmpPrev
DeleteDC hDCmem
移到GetDIBits()之后去執行。
大致看了下你的代碼，感覺主要問題應該在這兒。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/85566.html
標籤：API
上一篇：高分求助 關于 VSFlexGridPro 8.0的問題
下一篇：vba快速獲取word大綱文本