【分享】VB6 區域查找顏色範例 請問有比較好的方式嗎?
Option Explicit
Private Type POINTAPI '滑鼠座標XY參數
X As Long
Y As Long
End Type
'取得色碼
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
'取得滑鼠座標
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'取得句柄
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 300 '循環毫秒
'Timer1.Enabled = False '循環停止
End Sub
Private Sub Command1_Click()
Timer1.Enabled = False '循環停止
Dim Col3 As String, intXY As String, FFcl As Long
Dim X1 As Long, X2 As Long, Y1 As Long, Y2 As Long, Nux As Byte, Nuy As Byte
Label6.Caption = "開始查找"
Label7.Caption = ""
Delay 10
X1 = Text1.Text '尋找座標X1
Y1 = Text2.Text
X2 = Text3.Text
Y2 = Text4.Text '尋找座標Y2
Col3 = Text5.Text '尋找顏色 '5EAB25
Nux = Val(Text6.Text)
Nuy = Val(Text7.Text)
intXY = FindColor(Col3, X1, Y1, X2, Y2, Nux, Nuy)
If intXY <> "" Then
Label6.Caption = "找到顏色"
Label7.Caption = "座標:" & intXY
Else
Label6.Caption = "未找到"
Label7.Caption = ""
Timer1.Enabled = True '循環開始
End If
End Sub
'區域找 色顏色X1,Y1,X2,Y2,模糊值
Private Function FindColor(ColH As String, inX1 As Long, inY1 As Long, inX2 As Long, inY2 As Long, Nux As Byte, Nuy As Byte) '區域找 色顏色X1,Y1,X2,Y2,模糊值
Dim lDC As Long, ColA As Long, i As Long, p As Long, ColB As Long
lDC = GetWindowDC(0) '取得最底層視窗句柄
ColA = Val("&H" & ColH & "&")
For i = inY1 To inY2 Step Nuy
For p = inX1 To inX2 Step Nux
ColB = GetPixel(lDC, p, i)
If ColA = ColB Then
FindColor = p & "," & i '返回找到座標
Exit Function
End If
Next p
Next i
End Function
'取單點顏色
Private Function GetPixelColor(inX As Long, inY As Long) '取單點顏色
Dim lColor As Long, lDC As Long
lDC = GetWindowDC(0) '取得最底層視窗句柄
lColor = GetPixel(lDC, inX, inY) '取得座標點色碼
GetPixelColor = Right$("000000" & Hex(lColor), 6) '轉成16進制
End Function
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI '滑鼠座標
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long
lDC = GetWindowDC(0) '取得視窗句柄
Call GetCursorPos(tPOS) '取得滑鼠座標
lColor = GetPixel(lDC, tPOS.X, tPOS.Y) '取得座標點色碼
sTmp = Right$("000000" & Hex(lColor), 6) '轉成16進制
Label9.Caption = tPOS.X & "," & tPOS.Y
Label11.Caption = sTmp
Label12.BackColor = lColor
End Sub
Private Sub Delay(ByVal Sec As Single) '延遲毫秒
Dim sgnThisTime As Single, sgnCount As Single
Sec = Sec / 1000
sgnThisTime = Timer
Do While sgnCount < Sec
sgnCount = Timer - sgnThisTime
DoEvents
Loop
End Sub
[此贴子已经被作者于2022-3-4 10:36编辑过]