网站 › 『编程语言区』 › VB 高速屏幕找色...

幼儿园小班 发表于 2011-5-22 01:09

VB 高速屏幕找色...

Option Explicit
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0&
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 RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
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 SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 GetDC Lib "user32" (ByVal hwnd 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Const OBJ_BITMAP As Long = &H7
Dim iBitmap As Long, iDC As Long
Private m_Color() As Long
Private Sub GetColor()
    On Error GoTo ToEnd
    Dim bi24BitInfo As BITMAPINFO, bBytes() As Byte, Cnt As Long
    Dim TmpColor As Long
    Dim W As Long, h As Long
    Dim X As Long, Y As Long
    Dim R As Long
    Dim hdc As Long
    Dim TmpX As Long, TmpY As Long
    Err.Clear
    Erase m_Color
    W = Screen.Width / Screen.TwipsPerPixelX
    h = Screen.Height / Screen.TwipsPerPixelY
    With bi24BitInfo.bmiHeader
      .biBitCount = 24
      .biCompression = BI_RGB
      .biPlanes = 1
      .biSize = Len(bi24BitInfo.bmiHeader)
      .biWidth = W
      .biHeight = h
    End With
    hdc = GetDC(0)
    ReDim bBytes(bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3 - 1) As Byte
    iDC = CreateCompatibleDC(0)
    iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    SelectObject iDC, iBitmap
    BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, GetDC(0), 0, 0, vbSrcCopy
    GetDIBits iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(0), bi24BitInfo, DIB_RGB_COLORS
    ReDim m_Color(W, h)
    For Y = h To 1 Step -1
      TmpX = 0
      For X = 1 To W
            CopyMemory TmpColor, bBytes(R), 3
            m_Color(X, Y) = TmpColor
            R = R + 3
            TmpX = TmpX + 1
      Next
      TmpY = TmpY + 1
    Next
ToEnd:
    If Err.Number <> 0 Then MsgBox Err.Description
    Erase bBytes
    DeleteDC iDC
    DeleteDC hdc
    DeleteObject iBitmap
End Sub
Public Sub SCanColor(StartX, StartY, EndX, EndY, Color, RGBPoor, SCanType, P, ReturnX, ReturnY)
    'If CshPd Then MsgBox "试用到期!", 0, "": Exit Function
    'RGBPoor = RBG各项的差值
    'SCanType = 查找方式,值 1=左上到右下,2=右下到左上,3=右上到左下,4=左下到右上
    'P = 是否从新获取屏幕,值 1=从新获取,0=不从新获取
    'On Error Resume Next
    'If UBound(m_Color(), 1) <= 1 Then GetColor
    Color = Replace(Color, "#", "")
    Color = CLng("&h" & Color)
    Color = (&HFF And Color) * &H10000 + (&HFF00& And Color) + (&HFF0000 And Color) / &H10000
    Dim R As Long, G As Long, B As Long
    Dim R1 As Long, G1 As Long, B1 As Long
    Dim TColor As Long
    Dim I As Long, j As Long
    Dim Ei As Long, Ej As Long
    Dim Si As Long, Sj As Long
    Dim StepC As Long, StepC1 As Long
    Dim TP As Boolean
    B = (Color \ 65536) And &HFF
    G = (Color \ 256) And &HFF
    R = Color And &HFF
    If CBool(P) Then GetColor
    Select Case Val(SCanType)
    Case 1
      Si = StartY
      Sj = StartX
      Ei = EndY
      Ej = EndX
      StepC = 1
      StepC1 = 1
    Case 2
      Si = EndY
      Sj = EndX
      Ei = StartY
      Ej = StartX
      StepC = -1
      StepC1 = -1
    Case 3
      Si = EndX
      Sj = StartY
      Ei = StartX
      Ej = EndY
      StepC = -1
      StepC1 = 1
      TP = True
    Case 4
      Si = StartX
      Sj = EndY
      Ei = EndX
      Ej = StartY
      StepC = 1
      StepC1 = -1
      TP = True
    Case Else
      ReturnX = -1
      ReturnY = -1
      Exit Sub
    End Select
    For I = Si To Ei Step StepC
      For j = Sj To Ej Step StepC1
            If TP Then
                TColor = m_Color(I, j)
                B1 = (TColor \ 65536) And &HFF
                G1 = (TColor \ 256) And &HFF
                R1 = TColor And &HFF
                If Abs(B1 - B) < RGBPoor And Abs(G1 - G) < RGBPoor And Abs(R1 - R) < RGBPoor Then
                  ReturnX = I - 1
                  ReturnY = j - 1
                  Exit Sub
                End If
            Else
                TColor = m_Color(j, I)
                B1 = (TColor \ 65536) And &HFF
                G1 = (TColor \ 256) And &HFF
                R1 = TColor And &HFF
                If Abs(B1 - B) < RGBPoor And Abs(G1 - G) < RGBPoor And Abs(R1 - R) < RGBPoor Then
                  ReturnX = j - 1
                  ReturnY = I - 1
                  Exit Sub
                End If
            End If
      Next
    Next
    ReturnX = -1
    ReturnY = -1
End Sub
Public Function GetPixelColor(X, Y, P) As String
    On Error GoTo er
    Dim T As Long
    If CBool(P) Then GoTo er
    T = m_Color(X, Y)
    T = (&HFF And T) * &H10000 + (&HFF00& And T) + (&HFF0000 And T) / &H10000
    GetPixelColor = "#" & Hex(T)
    Exit Function
er:
    GetColor
    T = m_Color(X, Y)
    T = (&HFF And T) * &H10000 + (&HFF00& And T) + (&HFF0000 And T) / &H10000
    GetPixelColor = "#" & Hex(T)
End Function

NuclearAtk 发表于 2011-7-12 17:29

Option Explicit

'快速查找屏幕上指定颜色的位置模块
'用法：FindColor_RGB Val("&H00000080&")，当找到指定颜色就会调用函数 ColorXY。
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 'color table in RGBs
Private Type BITMAPINFOHEADER '40 bytes
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type RGBCOLOR
rgbRed As Byte
rgbGreen As Byte
rgbBlue As Byte
rgbReserved As Byte
End Type
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Function ColorXY(x As Long, y As Long) '当找到指定颜色就会调用该函数
BitBlt GetDC(0), x, y, 8, 8, GetDC(Form1.Picture1.hwnd), 0, 0, 13369376 '在找到的位置涂色标记
Form1.Caption = x & " " & y '显示坐标
End Function

Public Function FindColor_RGB(TargetColor As Long) '查找屏幕上指定颜色的位置，格式：FindColor_RGB (&HFF&)，FindColor_RGB
Dim hmemDC As Long, hmemBMP As Long, bmp_info As BITMAPINFO, lpBits As Long
Dim dwX As Long, dwY As Long
Dim PicData() As Byte
Dim ScreenDC As Long
Dim crColor As RGBCOLOR
CopyMemory crColor, TargetColor, 4
ScreenDC = GetDC(0)
With bmp_info.bmiHeader
.biSize = LenB(bmp_info.bmiHeader)
.biWidth = Screen.Width / Screen.TwipsPerPixelX
.biHeight = Screen.Height / Screen.TwipsPerPixelY
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
.biSizeImage = .biHeight * (((.biWidth * .biBitCount + 31) And &HFFFFFFE0) \ 8)
End With
hmemDC = CreateCompatibleDC(ScreenDC)
hmemBMP = CreateDIBSection(ScreenDC, bmp_info, DIB_RGB_COLORS, lpBits, 0, 0)
SelectObject hmemDC, hmemBMP
BitBlt hmemDC, 0, 0, bmp_info.bmiHeader.biWidth, bmp_info.bmiHeader.biHeight, ScreenDC, 0, 0, vbSrcCopy
ReDim PicData(3, bmp_info.bmiHeader.biWidth - 1, bmp_info.bmiHeader.biHeight - 1) As Byte
CopyMemory PicData(0, 0, 0), ByVal lpBits, bmp_info.bmiHeader.biSizeImage
'Debug.Print "查找坐标范围：(0,0) - (" & CStr(bmp_info.bmiHeader.biWidth - 1) & "," & CStr(bmp_info.bmiHeader.biHeight - 1) & ")"
For dwY = 0 To bmp_info.bmiHeader.biHeight - 1
For dwX = 0 To bmp_info.bmiHeader.biWidth - 1
If (PicData(0, dwX, dwY) = crColor.rgbBlue) And (PicData(1, dwX, dwY) = crColor.rgbGreen) And (PicData(2, dwX, dwY) = crColor.rgbRed) Then
ColorXY dwX, (bmp_info.bmiHeader.biHeight - dwY - 1) '已找到，调用函数处理
End If
Next
Next
DeleteDC hmemDC
DeleteObject hmemBMP
ReleaseDC 0, ScreenDC
End Function


另一种

音乐coffee 发表于 2011-7-12 17:29

嗯， 不错不错， 谢谢分享代码 ！

hack、小楠 发表于 2011-7-12 21:51

谢谢楼主分享代码、真不错:lol

xxhaishixx 发表于 2012-1-8 01:02

很不错的代码，可以写外挂的时候用

zz12 发表于 2012-7-5 01:56

高速屏幕找色 是啥子意思

gyshgx868 发表于 2013-2-12 23:04

这个东西怎么用啊？

a326700643 发表于 2013-5-22 04:11

正需要，楼主辛苦，看看代码先

fyq76 发表于 2013-7-1 11:14

谢谢楼主分享代码、真不错

dengzikai 发表于 2013-7-7 19:24

支持下先啊呵呵！

查看完整版本: VB 高速屏幕找色...