大家来研究一下这个VB全屏幕找图找色代码

sayonekui · 发表于 2011-9-30 12:48:53

本帖最后由 sayonekui 于 2011-9-30 12:55 编辑

Option Explicit
Dim mousestep As POINTAPI
Dim moubegin As POINTAPI
'获得当前光标的坐标。
'GetCursorPos moubegin
' mousestep = moubegin
'鼠标移到 SetCursorPos moubegin.X, moubegin.Y
'====================================================
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
Dim intX As Long
Dim intY As Long
'颜色表
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 FindPic(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 = ScaleX(P2W, vbHimetric, vbPixels)
H2 = 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(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
intX = I
intY = J
ExitLine:
Next I
Next J
'获得当前光标的坐标。
'GetCursorPos moubegin
'mousestep = moubegin
'鼠标移到
End Function
Public Function MoveTo(X As Long, Y As Long)
SetCursorPos X, Y
End Function
Private Sub Cmd1_Click()
Dim TimerMsg
Dim sTimer As Single '''定义操作时间计时变量
sTimer = Timer '''记录遍历图片内容的开始时间
FindPic CLng(Text1.Text), CLng(Text2.Text), CLng(Text3.Text), CLng(Text4.Text), Text5.Text
If intX > 0 And intY > 0 Then
MoveTo intX, intY
mouse_event &H4 Or &H2, 0, 0, 0, 0 '左键单击
TimerMsg = "找到坐标: " & intX & "," & intY
intX = 0
intY = 0
Else
TimerMsg = "?有找到"
End If
sTimer = Timer - sTimer '''计时结束,并记录用时长度
TimerMsg = TimerMsg & vbCrLf & " 用时: " & sTimer * 1000 & "毫秒" '''显示异点,和耗时
Label2.Caption = TimerMsg
End Sub

复制代码

由于本人学习VB不久能力有限上面是网上下载的一个源码修改的可以全屏找色的代码
其中有一段代码 :

PP.PSet (I2, J2), RGB(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))

复制代码

如果直接 PSet 窗体内会闪一下出现小图
所以用了 dim PP as new form1
问一下大家有木有其他更好的办法解决 ?
期待高手出现帮忙优化找图代码......

sayonekui · 发表于 2011-10-1 02:42:47

VBGOOD ?人，板凳自已坐...

ccc000 · 发表于 2011-10-2 10:30:15

代码比较长，要认真看了

xrkming · 发表于 2011-10-3 11:47:05

好像找不到

xuqin3 · 发表于 2011-10-3 12:36:17

sayonekui 发表于 2011-10-1 02:42
VBGOOD ?人，板凳自已坐...

xjjyho · 发表于 2011-10-8 21:06:27

看看啊啊啊啊

xrkming · 发表于 2011-10-9 11:58:31

前台还是后台？？

失忆 · 发表于 2018-11-2 17:00:18

这个是前台的。谁能做后台的，做出来共享下？

unkhzero · 发表于 2018-11-25 12:59:43

這個我最後都不太會用

		自动登录	找回密码
密码			立即注册

VBGood网站全文搜索

[讨论] 大家来研究一下这个VB全屏幕找图找色代码

本帖子中包含更多资源

本帖被以下淘专辑推荐: