<開源> 螢幕視窗找圖

程式名稱：視窗找圖本

程式說明：
　1.開放原始碼讓大家研究
　2.請勿用於商業用途

掃毒報告：觀看

偵測率:

0 / 57

教學開始：


程式碼：

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 ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long '釋放放DC
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () 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 SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y 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


Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

'----

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 _
)
 
'對API常量的定義
Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Const MOUSEEVENTF_MIDDLEUP = &H40
Const MOUSEEVENTF_MOVE = &H1
Const MOUSEEVENTF_ABSOLUTE = &H8000
Const MOUSEEVENTF_RIGHTDOWN = &H8
Const MOUSEEVENTF_RIGHTUP = &H10


Private Sub GetImageMemory(ByVal Pic As PictureBox, W As Long, H As Long, Memory() As Byte, bi As BITMAPINFO)
    With bi.bmiHeader
        .biCompression = 0&
        .biSize = Len(bi.bmiHeader)
        .biWidth = W
        .biHeight = -H
        .biBitCount = 32
        .biPlanes = 1
    End With
    ReDim Memory(3, 0 To W - 1, 0 To H - 1)
    GetDIBits Pic.hdc, Pic.Picture.Handle, 0&, H, Memory(0, 0, 0), bi, 0&
    ReleaseDC 0, Pic.hdc
End Sub
Private Sub saveMyScreen()
        Dim lngDesktopHwnd As Long
        Dim lngDesktopDC As Long
 
        Form1.Picture2.AutoRedraw = True
        Form1.Picture2.ScaleMode = vbPixels
        lngDesktopHwnd = GetDesktopWindow
        lngDesktopDC = GetDC(lngDesktopHwnd)
 
        Form1.Picture2.Width = Screen.Width
        Form1.Picture2.Height = Screen.Height
        Call BitBlt(Form1.Picture2.hdc, 0, 0, Screen.Width, Screen.Height, lngDesktopDC, 0, 0, SRCCOPY)
        Form1.Picture2.Picture = Form1.Picture2.Image
        Call ReleaseDC(lngDesktopHwnd, lngDesktopDC)
End Sub
'開始
Public Function FindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, fileurl As String, SimRate As Long, intX As Long, intY As Long) As Boolean
    Dim zPic() As Byte, fPic() As Byte
    Dim zImg As BITMAPINFO, fImg As BITMAPINFO
    Dim Now As Long, Noh As Long
    Dim I As Long, J As Long, I2 As Long, J2 As Long
    Dim W As Long, H As Long
    Set Form1.Picture1.Picture = LoadPicture(fileurl)
    W = Form1.Picture1.ScaleWidth / Screen.TwipsPerPixelX
    H = Form1.Picture1.ScaleHeight / Screen.TwipsPerPixelY
    GetImageMemory Form1.Picture1, W, H, zPic(), zImg
    W = Right
    H = Bottom
    saveMyScreen
    GetImageMemory Form1.Picture2, W, H, fPic(), fImg
    Now = Round(UBound(zPic, 2) / 10) + 1
    Noh = Round(UBound(zPic, 3) / 10) + 1
    For J = Top To H - UBound(zPic, 3)
        For I = Left To W - UBound(zPic, 2)
            For J2 = 0 To UBound(zPic, 3) - 1 Step Noh '循環判斷小圖片
                For I2 = 0 To UBound(zPic, 2) - 1 Step Now
 
                    If SimRate < Abs(CInt(fPic(2, I + I2, J + J2)) - CInt(zPic(2, I2, J2))) Then GoTo ExitLine: 'R
                    If SimRate < Abs(CInt(fPic(1, I + I2, J + J2)) - CInt(zPic(1, I2, J2))) Then GoTo ExitLine: 'G
                    If SimRate < Abs(CInt(fPic(0, I + I2, J + J2)) - CInt(zPic(0, I2, J2))) Then GoTo ExitLine: 'b
                Next I2
            Next J2
            '
            intX = I
            intY = J
            FindPic = True
            I = W - UBound(zPic, 2)
            J = H - UBound(zPic, 3)
ExitLine:
        Next I
    Next J
 
End Function

Private Sub Command1_Click()
Dim intX As Long, intY As Long
Dim sTimer As Single
sTimer = Timer

FindPic CLng(Text1.Text), CLng(Text2.Text), CLng(Text3.Text), CLng(Text4.Text), Text5.Text, Text6.Text, intX, intY
If intX > 0 Then '開始
SetCursorPos intX, intY
mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 '鼠標左鍵的按下
mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 '鼠標左鍵的彈起
Label1 = "找到座標：" & intX & ";" & intY
Else
Label1 = "沒有找到"
End If

sTimer = Timer - sTimer
Label1 = Label1 & vbCrLf & " 用了: " & sTimer * 1000 & "毫秒"
End Sub

專案檔懶人包下載：
　點我下載


壓縮密碼：
　分享於- http://bps1331.blogspot.tw/