VB极速找色法：
'添加这些API
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) 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 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 Type BitMapInfoHeader ''文件信息头——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
——————————————————————
‘’添加以下函数
Public Function speedgetcor(obj As PictureBox, scx As Integer, scy As Integer) '获取 图片框 scx,scy位置的颜色值
Dim ix As Integer
Dim iy As Integer
Dim iWidth As Integer '以像素为单位的图形宽度
Dim iHeight As Integer '以像素为单位的图形高度
Dim bytGray As Byte
Dim bytThreshold As Byte
Dim bits() As Byte '三维数组，用于获取原彩色图像中各像素的RGB数值以及存放转化后的灰度值
Dim bitsBW() As Byte '三维数组，用于存放转化为黑白图后各像素的值
'获取图形的宽度和高度
iWidth = obj.ScaleWidth '/ Screen.TwipsPerPixelX
iHeight = obj.ScaleHeight '/ Screen.TwipsPerPixelY
obj.Picture = obj.Image
'创建并初始化一个bitMapInfo自定义类型
Dim bi24BitInfo As BitMapInfo
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = iWidth
.biHeight = iHeight '/ Screen.TwipsPerPixelY
Debug.Print iWidth;
Debug.Print iHeight;
Debug.Print Len(bi24BitInfo.bmiHeader)
End With
'重新定义数组大小
ReDim bits(3, 0 To iWidth - 1, 0 To iHeight - 1) As Byte
ReDim bitsBW(3, 0 To iWidth - 1, 0 To iHeight - 1) As Byte
'使用GetDIBits方法一次性获取obj中各点的rgb值，比point方法或getPixel函数逐像素获取像素rgb要快出一个数量级
lrtn = GetDIBits(obj.hdc, obj.Picture.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, 0&)
'数组的三个维度分别代表像素的RGB分量、以图形左下角为原点的X和Y坐标。
'具体说来，这时bits(0,2,3)代表从图形左下角数起横向第2个纵向第3个像素的Blue值，而bits(1,2,3)和bits(2,2,3)分别的Green值和Red值.
'Debug.Print "lrtn：" & lrtn
iht = iHeight - 1
speedgetcor = Hex(Val(RGB(bits(2, scx, iht - scy), bits(1, scx, iht - scy), bits(0, scx, iht - scy))))
End Function
Public Function speedfindcor(obj As PictureBox, spx1 As Integer, spy1 As Integer, spx2 As Integer, spy2 As Integer, cor As Variant) As Variant
Dim ix As Integer
Dim iy As Integer
Dim iWidth As Integer '以像素为单位的图形宽度
Dim iHeight As Integer '以像素为单位的图形高度
Dim bytGray As Byte
Dim bytThreshold As Byte
Dim bits() As Byte '三维数组，用于获取原彩色图像中各像素的RGB数值以及存放转化后的灰度值
Dim bitsBW() As Byte '三维数组，用于存放转化为黑白图后各像素的值
'获取图形的宽度和高度
iWidth = obj.ScaleWidth '/ Screen.TwipsPerPixelX
iHeight = obj.ScaleHeight '/ Screen.TwipsPerPixelY
obj.Picture = obj.Image
'创建并初始化一个bitMapInfo自定义类型
Dim bi24BitInfo As BitMapInfo
With bi24BitInfo.bmiHeader
.biBitCount = 32
.biCompression = 0&
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = iWidth
.biHeight = iHeight '/ Screen.TwipsPerPixelY
Debug.Print iWidth;
Debug.Print iHeight;
Debug.Print Len(bi24BitInfo.bmiHeader)
End With
'重新定义数组大小
ReDim bits(3, 0 To iWidth - 1, 0 To iHeight - 1) As Byte
ReDim bitsBW(3, 0 To iWidth - 1, 0 To iHeight - 1) As Byte
'使用GetDIBits方法一次性获取obj中各点的rgb值，比point方法或getPixel函数逐像素获取像素rgb要快出一个数量级
lrtn = GetDIBits(obj.hdc, obj.Picture.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, 0&)
'数组的三个维度分别代表像素的RGB分量、以图形左下角为原点的X和Y坐标。
'具体说来，这时bits(0,2,3)代表从图形左下角数起横向第2个纵向第3个像素的Blue值，而bits(1,2,3)和bits(2,2,3)分别的Green值和Red值.
'Debug.Print "lrtn：" & lrtn
iht = iHeight - 1
For isy = spy1 To spy2
For isx = spx1 To spx2
tempcor = Hex(Val(RGB(bits(2, isx, iht - isy), bits(1, isx, iht - isy), bits(0, isx, iht - isy))))
If tempcor = cor Then
speedfindcor = isx & "," & isy
Exit Function
End If
Next
DoEvents
Next
End Function
Public Function getx(str As Variant) As Variant
If Left(str, 1) = "(" Then
getx = Mid(str, 2, InStr(1, str, ",") - 2)
Exit Function
End If
If Left(str, 1) <> "(" Then
getx = Mid(str, 1, InStr(1, str, ",") - 1)
Exit Function
End If
End Function
Public Function gety(str As Variant) As Variant
If Right(str, 1) = ")" Then
gety = Mid(str, InStr(1, str, ",") + 1, Len(str) - (InStr(1, str, ",") + 1))
Exit Function
End If
If Right(str, 1) <> ")" Then
gety = Mid(str, InStr(1, str, ",") + 1, Len(str) - InStr(1, str, ","))
Exit Function
End If
End Function
菠萝蜜
