vb多次全屏找图后出现的问题-大神帮忙啊，急！

[shinni987654]

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代码，经过测试，找一两张图没什么问题，但是多找几张后就找不到了，键盘截屏后
粘贴到画图板发现是黑白的，多截几次出现剪贴板错误，本人技术有限，检查了多遍代码找不出问题，请各位大侠帮忙看看
是哪里出问题了。
下面是多次找图后键盘截屏的图片

[赵4老师]

GDI泄露，我猜。 搜“GDI泄露检测”

[舉杯邀明月]

引用 2 楼 zhao4zhong1 的回复:

GDI泄露，我猜。 搜“GDI泄露检测”

这还去猜啊，他的代码比较明显的首要问题就是这个，在他的另一个贴子中，我就解释过了。 重复提问帖。　

[舉杯邀明月]

Pic1Handle 这个句柄，他也没用调用DeleteObject来删除GDI对象。

[舉杯邀明月]

再急也没必要重复发帖子啊，你以为这是聊天室群聊啊，发个消息一不小心就被别人的消息“淹没”了…… 这个版块很冷清的，随便发个贴子都能在“首页”摆几天， 有人来逛这块，都很容易看到的。