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熱心網友回復：
再急也沒必要重復發帖子啊，你以為這是聊天室群聊啊，發個訊息一不小心就被別人的訊息“淹沒”了……
這個版塊很冷清的，隨便發個貼子都能在“首頁”擺幾天，
有人來逛這塊，都很容易看到的。
uj5u.com熱心網友回復：
GDI泄露，我猜。搜“GDI泄露檢測”
uj5u.com熱心網友回復：
這還去猜啊，他的代碼比較明顯的首要問題就是這個，在他的另一個貼子中，我就解釋過了。
重復提問帖。
uj5u.com熱心網友回復：
Pic1Handle 這個句柄，他也沒用呼叫DeleteObject來洗掉GDI物件。轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/85571.html
標籤：多媒體
下一篇：ADO訪問mysql資料庫