Option Explicit
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 POINT
X As Integer
Y As Integer
End Type
Private Const DIB_RGB_COLORS As Long = &H0&
Private Const BI_RGB As Long = &H0&
Private Const OBJ_BITMAP As Long = &H7&
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
ByVal nNumScans As Long, ByVal lpBits As Long, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType 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 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 Function findColor(ByVal hdc As Long, ByVal Width As Integer, ByVal Height As Integer, ByVal find_Color As Long, ByRef retClr() As POINT) As Long
Dim bi As BITMAPINFO
Dim LngCol As Long, hMap As Long, lenBuf As Long, r As Long, s As Long
Dim bmpBuf() As Byte
Dim X As Integer, Y As Integer
Erase retClr
find_Color = (&HFF And find_Color) * &H10000 + (&HFF00& And find_Color) + (&HFF0000 And find_Color) / &H10000
With bi.bmiHeader
.biSize = Len(bi.bmiHeader)
.biWidth = Width
.biHeight = Height
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
End With
lenBuf = CLng(Width) * Height * 3
ReDim bmpBuf(lenBuf - 1)
hMap = GetCurrentObject(hdc, OBJ_BITMAP)
GetDIBits hdc, hMap, 0, bi.bmiHeader.biHeight, VarPtr(bmpBuf(0)), bi, DIB_RGB_COLORS
Dim aa As Long
For Y = Height To 1 Step -1
For X = 1 To Width
CopyMemory LngCol, bmpBuf(r), 3
If LngCol = find_Color Then
ReDim Preserve retClr(s)
With retClr(s)
.X = X
.Y = Y
End With
s = s + 1
aa = 3
' Exit For
End If
r = r + 3
Next
'If aa = 3 Then
'Exit For
'End If
Next
Erase bmpBuf
findColor = s
End Function
Private Sub Command1_Click()
On Error Resume Next
Dim a As Long, b As Long
a = 0
b = 0
Dim hdc As Long, sint As Single, retClr() As POINT, ret As Long
sint = Timer
' hdc = GetDC(526622)
hdc = GetDC(0)
' ret = findColor(hdc, 640, 480, &HF7F718, retClr())
ret = findColor(hdc, 1280, 800, &H28394D, retClr())
ReleaseDC 0, hdc
If ret <> 0 Then
MoveTo retClr(a).X, retClr(a).Y
MsgBox "此顏色點數:" & ret & " 用時: " & (Timer - sint) & " 坐標" & retClr(a).X & " " & retClr(a).Y
'MsgBox "此顏色點數:" & ret & " 用時: " & (Timer - sint) '& " 坐標" & retClr(a).x & " " & retClr(a).y
Else
MsgBox "未找到"
End If
End Sub
這是螢屏找一個顏色的代碼，怎樣實作通過找顏色相鄰的坐標顏色固定找到顏色坐標的目的。
uj5u.com熱心網友回復：
vb做這種事比C/C++慢。uj5u.com熱心網友回復：
參考http://www.autohotkey.com源代碼中ImageSearch功能的實作。uj5u.com熱心網友回復：
那不是vb的代碼uj5u.com熱心網友回復：
怎樣實作通過找顏色相鄰的坐標顏色固定找到顏色坐標的目的沒法理解這句話的意思。
難道是我還需要“深造”一下，學習漢語的語法么……
uj5u.com熱心網友回復：
前面那個代碼最后回傳的坐標是最后一個顏色的坐標，我想找到一個顏色后，通過這個顏色附近其他坐標的顏色固定我要找的坐標。我用getpixel找到的不對，但是在找到第一個點后用debug輸出getpixel坐標顏色確實對的，用if判斷就不行
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/84147.html
標籤：VB基礎類