VB原创纯代码全屏找图找色（支持色偏，透明图）
N年前初识VB时写的代码，乱了点，各位将就看看把，如果有需求下次发上GDI后台的图色，等同于大漠GDI后台（某位大牛逆向大漠插件得到的方法，我有空就写了出来）VB开发的图色识别速度上与C++开发的其实相差并不是很大，1440*900扫描一张图，都在稳定100MS内完成，只有在找透明图
时，遇到非透明色的颜色和待找大图中大部分颜色相同时，效率会远远低于C++，貌似循环套嵌效率没C++高。
（透明图指的是图片四个角颜色相同，默认图片中该色为透明图，忽略该种颜色的对比）
管理可精否？
找色部分
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 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
Dim intZ 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
Public Function FindColorEx(Left As Long, Top As Long, Right As Long, Bottom As Long, color As String) As String
Dim l() As String
Dim ld As Long
Dim W As Long, H As Long, i As Long, j As Long
Dim RGB(3) As Long
Dim fPic() As Byte
l = Split(color, "|")
Dim m As Long
W = Right
H = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
ReDim fPic(3, W - 1, H - 1)
Dim hBMPhDC
Dim hDCmem As Long
Dim Pic1Handle As Long
Dim hBmpPrev As Long
hBMPhDC = GetDC(0)
hDCmem = CreateCompatibleDC(hBMPhDC)
Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
For ld = 0 To UBound(l)
For m = 0 To 2
RGB(m) = CLng("&H" & Mid(l(ld), m * 2 + 1, 2))
Next
'分析查找
For j = 0 To H - 1
For i = 0 To W - 1
If fPic(2, i, j) <> RGB(0) Then GoTo ExitLine: 'R
If fPic(1, i, j) <> RGB(1) Then GoTo ExitLine: 'G
If fPic(0, i, j) <> RGB(2) Then GoTo ExitLine: 'B
If FindColorEx = "" Then
FindColorEx = ld & "," & i & "," & j
Else
FindColorEx = FindColorEx & "|" & ld & "," & i & "," & j
End If
ExitLine:
Next i
Next j
Next
End Function
Public Function FindColor(Left As Long, Top As Long, Right As Long, Bottom As Long, color As String) As String
Dim l() As String
Dim W As Long, H As Long, i As Long, j As Long
Dim RGB(3) As Byte
Dim fPic() As Byte
Dim m As Long
W = Right
H = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
ReDim fPic(3, W - 1, H - 1)
Dim hBMPhDC
Dim hDCmem As Long
Dim Pic1Handle As Long
Dim hBmpPrev As Long
hBMPhDC = GetDC(0)
hDCmem = CreateCompatibleDC(hBMPhDC)
Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
For m = 0 To 2
RGB(m) = CLng("&H" & Mid(color, m * 2 + 1, 2))
Next
'分析查找
For j = 0 To H - 1
For i = 0 To W - 1
If fPic(2, i, j) <> RGB(0) Then GoTo ExitLine: 'R
If fPic(1, i, j) <> RGB(1) Then GoTo ExitLine: 'G
If fPic(0, i, j) <> RGB(2) Then GoTo ExitLine: 'B
FindColor = i & "," & j
Exit Function
ExitLine:
Next i
Next j
End Function
Public Function FindColorE(Left As Long, Top As Long, Right As Long, Bottom As Long, color As String, sim As Double) As String
Dim l() As String
Dim W As Long, H As Long, i As Long, j As Long
Dim RGB(3) As Byte
Dim fPic() As Byte
Dim m As Long
sim = (1 - (1 - sim) * 0.65)
W = Right
H = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
ReDim fPic(3, W - 1, H - 1)
Dim hBMPhDC
Dim hDCmem As Long
Dim Pic1Handle As Long
Dim hBmpPrev As Long
hBMPhDC = GetDC(0)
hDCmem = CreateCompatibleDC(hBMPhDC)
Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
For m = 0 To 2
RGB(m) = CLng("&H" & Mid(color, m * 2 + 1, 2))
Next
'分析查找
For j = 0 To H - 1
For i = 0 To W - 1
If fPic(2, i, j) < CLng(RGB(0) * sim) Or fPic(2, i, j) > CLng(RGB(0) * (2 - sim)) Then GoTo ExitLine: 'R
If fPic(1, i, j) < CLng(RGB(1) * sim) Or fPic(1, i, j) > CLng(RGB(1) * (2 - sim)) Then GoTo ExitLine: 'G
If fPic(0, i, j) < CLng(RGB(2) * sim) Or fPic(0, i, j) > CLng(RGB(2) * (2 - sim)) Then GoTo ExitLine: 'B
FindColorE = i & "," & j
Exit Function
ExitLine:
Next i
Next j
End Function vb找图找色源代码出于何处？ 回帖支持楼主分享精神！ 这个如果做好比按键强多了
页:
[1]