VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 14469|回复: 8

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

[复制链接]
 楼主| 发表于 2011-9-30 12:48:53 | 显示全部楼层 |阅读模式
本帖最后由 sayonekui 于 2011-9-30 12:55 编辑
  1. Option Explicit
  2. Dim mousestep As POINTAPI
  3. Dim moubegin As POINTAPI
  4.     '获得当前光标的坐标。
  5.     'GetCursorPos moubegin
  6.    ' mousestep = moubegin
  7.    '鼠标移到 SetCursorPos moubegin.X, moubegin.Y
  8. '====================================================
  9. 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
  10. 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
  11. '====================================================
  12. 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)
  13. '左键单击
  14. '====================================================
  15. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '获取句柄
  16. 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 '获取图片数据

  17. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal HDC As Long) As Long '释放DC

  18. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal HDC As Long) As Long
  19. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal HDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  20. Private Declare Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
  21. Private Declare Function SelectObject Lib "gdi32" (ByVal HDC As Long, ByVal hObject As Long) As Long
  22. Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

  23. Dim intX As Long
  24. Dim intY As Long

  25. '颜色表
  26. Private Type RGBQUAD
  27.     rgbBlue As Byte
  28.     rgbGreen As Byte
  29.     rgbRed As Byte
  30.     rgbAlpha As Byte   '透明通道
  31. End Type

  32. Private Type BITMAPINFOHEADER
  33.     biSize As Long          '位图大小
  34.     biWidth As Long
  35.     biHeight As Long
  36.     biPlanes As Integer
  37.     biBitCount As Integer   '信息头长度
  38.     biCompression As Long   '压缩方式
  39.     biSizeImage As Long
  40.     biXPelsPerMeter As Long
  41.     biYPelsPerMeter As Long
  42.     biClrUsed As Long
  43.     biClrImportant As Long
  44. End Type

  45. Private Type BITMAPINFO
  46.     bmiHeader As BITMAPINFOHEADER
  47.     bmiColors As RGBQUAD
  48. End Type

  49. '图片文件头
  50. Dim BI As BITMAPINFO
  51. Dim BI1 As BITMAPINFO
  52. Dim PP As New Form1


  53. '在图片1中查找图片2,是否找出全部
  54. Public Function FindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, fileurl As String)

  55. Dim P2 As Picture, P2W, P2H, P2Handle
  56. Set P2 = LoadPicture(fileurl)
  57. P2W = P2.Width
  58. P2H = P2.Height
  59. P2Handle = P2.Handle


  60. Dim W As Long, H As Long, I As Long, J As Long
  61. Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long

  62. Dim zPic() As Byte, fPic() As Byte
  63. Dim R As Byte, G As Byte, B As Byte

  64. '1 获得图片2数据
  65. W2 = ScaleX(P2W, vbHimetric, vbPixels)
  66. H2 = ScaleY(P2H, 8, 3)

  67. With BI.bmiHeader
  68.     .biSize = Len(BI.bmiHeader)
  69.     .biWidth = W2
  70.     .biHeight = -H2
  71.     .biBitCount = 32
  72.     .biPlanes = 1
  73. End With

  74. ReDim zPic(3, W2 - 1, H2 - 1)

  75. I = GetDIBits(HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
  76. Set P2 = Nothing
  77. 'Debug.Print I
  78. '如果在这里处理一下,图像大的话,可能会快一点。

  79. '2 获得图片1数据
  80. W = Right
  81. H = Bottom

  82. With BI1.bmiHeader
  83.     .biSize = Len(BI1.bmiHeader)
  84.     .biWidth = W
  85.     .biHeight = -H
  86.     .biBitCount = 32
  87.     .biPlanes = 1
  88. End With

  89.         For J2 = 0 To H2 - 2 '循环判断小图片
  90.             For I2 = 0 To W2 - 2
  91.                 PP.PSet (I2, J2), RGB(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))
  92.             Next I2
  93.         Next J2
  94.         PP.Refresh
  95.         
  96. ReDim fPic(3, W - 1, H - 1)

  97.      Dim hBMPhDC
  98.      Dim hDCmem As Long
  99.      Dim Pic1Handle As Long
  100.      Dim hBmpPrev As Long
  101.      hBMPhDC = GetDC(0)
  102.      '常规抓图代码,得到一个hBmp:
  103.      hDCmem = CreateCompatibleDC(hBMPhDC)
  104.      Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
  105.      hBmpPrev = SelectObject(hDCmem, Pic1Handle)
  106.      BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
  107.      'SelectObject hDCmem, hBmpPrev
  108.      DeleteDC hDCmem

  109. I = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)

  110. ReleaseDC 0, hBMPhDC


  111. 'Debug.Print I
  112. '分析查找
  113. For J = 0 To H - H2 - 1
  114. VBA.DoEvents
  115.     For I = 0 To W - W2 - 1
  116.         
  117.         For J2 = 0 To H2 - 2 '循环判断小图片
  118.             For I2 = 0 To W2 - 2
  119.                
  120.                 If fPic(2, I + I2, J + J2) <> zPic(2, I2, J2) Then GoTo ExitLine: 'R
  121.                 If fPic(1, I + I2, J + J2) <> zPic(1, I2, J2) Then GoTo ExitLine: 'G
  122.                 If fPic(0, I + I2, J + J2) <> zPic(0, I2, J2) Then GoTo ExitLine: 'B

  123.             Next I2
  124.         Next J2

  125.         'Debug.Print "发现:", I, J
  126.         intX = I
  127.         intY = J
  128.      
  129. ExitLine:
  130.     Next I
  131. Next J

  132.     '获得当前光标的坐标。
  133.     'GetCursorPos moubegin
  134.     'mousestep = moubegin
  135.     '鼠标移到

  136. End Function

  137. Public Function MoveTo(X As Long, Y As Long)
  138. SetCursorPos X, Y
  139. End Function

  140. Private Sub Cmd1_Click()
  141. Dim TimerMsg
  142. Dim sTimer As Single         '''定义操作时间 计时变量
  143. sTimer = Timer               '''记录遍历图片内容的开始时间

  144. FindPic CLng(Text1.Text), CLng(Text2.Text), CLng(Text3.Text), CLng(Text4.Text), Text5.Text
  145. If intX > 0 And intY > 0 Then
  146.     MoveTo intX, intY
  147.     mouse_event &H4 Or &H2, 0, 0, 0, 0 '左键单击
  148.     TimerMsg = "找到坐标: " & intX & "," & intY
  149.         intX = 0
  150.         intY = 0
  151.     Else
  152.     TimerMsg = "?有找到"
  153. End If

  154. sTimer = Timer - sTimer      '''计时结束,并记录用时长度
  155. TimerMsg = TimerMsg & vbCrLf & " 用时: " & sTimer * 1000 & "毫秒" '''显示异点,和耗时

  156. Label2.Caption = TimerMsg
  157.         
  158. End Sub


复制代码
由于本人学习VB不久 能力有限 上面是网上下载的一个源码修改的可以全屏找色的代码
其中有一段代码 :
  1. PP.PSet (I2, J2), RGB(zPic(2, I2, J2), zPic(1, I2, J2), zPic(0, I2, J2))
复制代码
如果直接 PSet 窗体内会闪一下出现小图
所以用了 dim PP as new form1
问一下大家有木有其他更好的办法解决 ?
期待高手出现帮忙优化找图代码......





本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x

本帖被以下淘专辑推荐:

 楼主| 发表于 2011-10-1 02:42:47 | 显示全部楼层
VBGOOD ?人,板凳自已坐...
回复 支持 反对

使用道具 举报

发表于 2011-10-2 10:30:15 | 显示全部楼层
代码比较长,要认真看了
回复 支持 反对

使用道具 举报

发表于 2011-10-3 11:47:05 | 显示全部楼层
好像找不到
回复 支持 反对

使用道具 举报

发表于 2011-10-3 12:36:17 | 显示全部楼层
sayonekui 发表于 2011-10-1 02:42
VBGOOD ?人,板凳自已坐...

回复 支持 反对

使用道具 举报

发表于 2011-10-8 21:06:27 | 显示全部楼层
看看啊啊啊啊
回复 支持 反对

使用道具 举报

发表于 2011-10-9 11:58:31 | 显示全部楼层
前台还是后台??
回复 支持 反对

使用道具 举报

发表于 2018-11-2 17:00:18 | 显示全部楼层
这个是前台的。谁能做后台的,做出来共享下?
回复 支持 反对

使用道具 举报

发表于 2018-11-25 12:59:43 | 显示全部楼层
這個我最後都不太會用
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-1 22:13

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表