Option Explicit
'====================================================
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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 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 Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
'颜表
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 Load As String
Dim PP As New Form1
Public Function 设置路径(ByVal Fileurl As String) As Boolean
Load = Fileurl
If Len(Load) <= 0 Then
设置路径 = False
Else
设置路径 = True
End If
End Function
Public Function FindPic(Left As Long, Top As Long, Right As Long, Bottom As Long, Fileurl As String, delta_color As String) As String
Dim P2 As Picture, P2W, P2H, P2Handle
If Load = "" Then
If Dir(Fileurl) = "" Then
MsgBox "This picture" & Fileurl & "cannot find, please confirm after path try again ! ", vbCritical, "ERR : Wrong
!"
Exit Function
End If
Set P2 = LoadPicture(Fileurl)
Else
If Dir(Load & "\" & Fileurl) = "" Then
MsgBox "This picture" & Load & "\" & Fileurl & "cannot find, please confirm after path try again ! ", vbCritical, "ERR : Wrong !"
Exit Function
End If
Set P2 = LoadPicture(Load & "\" & Fileurl)
End If
P2W = P2.Width
P2H = P2.Height
P2Handle = P2.Handle
Dim s As Double
Dim bmp As BITMAP
Dim xx As Long, yy As Long, bz As Long, x1 As Long, y1 As Long
Dim m As Long
Dim W As Long, H As Long, i As Long, j As Long
Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long
Dim RGB2(2) As Long
Dim zPic() As Byte, fPic() As Byte
Dim R As Long, G As Long, b As Long, x As Long, y As Long
For m = 0 To 2
RGB2(m) = CLng("&H" & Mid(delta_color, m * 2 + 1, 2))
Next
'1 获得图片2数据
W2 = Form1.ScaleX(P2W, vbHimetric, vbPixels)
H2 = Form1.ScaleY(P2H, 8, 3)
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = W2
.biHeight = -H2
.biBitCount = 32
.biPlanes = 1
End With
ReDim zPic(3, W2 - 1, H2 - 1)
i = GetDIBits(PP.HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
Set P2 = Nothing
'2 获得图片1数据
W = Right
H = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
If RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, W2 - 1, 0), zPic(1, W2 - 1, 0), zPic(0, W2 - 1, 0)) And _
RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, W2 - 1, H2 - 1), zPic(1, W2 - 1, H2 - 1), zPic(0, W2 - 1, H2 - 1)) And _
RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, 0, H2 - 1), zPic(1, 0, H2 - 1), zPic(0, 0, H2 - 1)) Then
R = zPic(2, 0, 0)
G = zPic(1, 0, 0)
b = zPic(0, 0, 0)
For J2 = 0 To H2 - 1 '左上角透明图
For I2 = 0 To W2 - 1
If zPic(2, I2, J2) = R Then GoTo NextLine: 'R
If zPic(1, I2, J2) = G Then GoTo NextLine: 'R
If zPic(0, I2, J2) = b Then GoTo NextLine: 'R
xx = I2
yy = J2
GoTo aac:
NextLine:
Next I2
Next J2
aac:
For J2 = H2 - 1 To yy Step -1 '右角透明图
For I2 = W2 - 1 To xx Step -1
If zPic(2, I2, J2) = R Then GoTo NextLine2: 'R
If zPic(1, I2, J2) = G Then GoTo NextLine2: 'R
If zPic(0, I2, J2) = b Then GoTo NextLine2: 'R
y1 = J2
GoTo aac2:
NextLine2:
Next I2
Next J2
aac2:
For I2 = W2 - 1 To yy Step -1 '下角透明图
For J2 = H2 - 1 To xx Step -1
If zPic(2, I2, J2) = R Then GoTo NextLine3: 'R
If zPic(1, I2, J2) = G Then GoTo NextLine3: 'R
If zPic(0, I2, J2) = b Then GoTo NextLine3: 'R
x1 = I2
GoTo aac3:
NextLine3:
Next J2
Next I2
aac3:
Else
xx = 0
yy = 0
x1 = W2
y1 = H2
R = G = b = -1
End If
bz = 0
ReDim fPic(3, W - 1, H - 1)
Dim hBMPhDC
Dim hDCmem As Long
Dim Pic1Handle As Long
Dim hBmpPrev As Long
hBMPhDC = GetDC(0)
'常规抓图代码，得到一个hBmp：
hDCmem = CreateCompatibleDC(hBMPhDC)
Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC,
Left, Top, SRCCOPY
'SelectObject hDCmem, hBmpPrev
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
For j = 0 To H - y1 - 2
For i = 0 To W - x1 - 2
s = 0
For J2 = yy To y1 - 2 '循环判断小图片
For I2 = xx To x1 - 2
If R = G = b = -1 Then
If fPic(2, i + I2, j + J2) < zPic(2, I2, J2) - RGB2(0) Or fPic(2, i + I2, j + J2) > zPic(2, I2, J2) + RGB2(0) Then GoTo ExitLine: 'R
If fPic(1, i + I2, j + J2) < zPic(1, I2, J2) - RGB2(1) Or fPic(1, i + I2, j + J2) > zPic(1, I2, J2) + RGB2(1) Then GoTo ExitLine: 'G
If fPic(0, i + I2, j + J2) < zPic(0, I2, J2) - RGB2(2) Or fPic(0, i + I2, j + J2) > zPic(0, I2, J2) + RGB2(2) Then GoTo ExitLine: 'B
Else
If fPic(2, i + I2, j + J2) < zPic(2, I2, J2) - RGB2(0) Or fPic(2, i + I2, j + J2) > zPic(2, I2, J2) + RGB2(0) And zPic(2, I2, J2) <> R Then GoTo ExitLine: 'R
If fPic(1, i + I2, j + J2) < zPic(1, I2, J2) - RGB2(1) Or fPic(1, i + I2, j + J2) > zPic(1, I2, J2) + RGB2(1) And zPic(1, I2, J2) <> G Then GoTo ExitLine: 'G
If fPic(0, i + I2, j + J2) < zPic(0, I2, J2) - RGB2(2) Or fPic(0, i + I2, j + J2) > zPic(0, I2, J2) + RGB2(2) And zPic(0, I2, J2) <> b Then GoTo ExitLine: 'B
End If
nc:
Next I2
Next J2
x = i + xx
y = j + yy
FindPic = x & "," & y
Exit Function
ExitLine:
Next i
Next j
End Function
Public Function FindPicE(Left As Long, Top As Long, Right As Long, Bottom As Long, Fileurl As String, delta_color As String) As String
Dim P2 As Picture, P2W, P2H, P2Handle
If Load = "" Then
If Dir(Fileurl) = "" Then
MsgBox "This picture" & Fileurl & "cannot find, please confirm after path try again !", vbCritical, "ERR : Wrong !"
Exit Function
End If
Set P2 = LoadPicture(Fileurl)
Else
If Dir(Load & "\" & Fileurl) = "" Then
MsgBox "This picture" & Load & "\" & Fileurl & "cannot find, please confirm after path try again !", vbCritical, "ERR : Wrong !"
Exit Function
End If
Set P2 = LoadPicture(Load & "\" & Fileurl)
End If
P2W = P2.Width
P2H = P2.Height
P2Handle = P2.Handle
Dim s As Double
Dim bmp As BITMAP
Dim xx As Long, yy As Long, bz As Long, x1 As Long, y1 As Long
Dim m As Long
Dim W As Long, H As Long, i As Long, j As Long
Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long
Dim RGB2(2) As Long
Dim zPic() As Byte, fPic() As Byte
Dim R As Long, G As Long, b As Long, x As Long, y As Long
For m = 0 To 2
RGB2(m) = CLng("&H" & Mid(delta_color, m * 2 + 1, 2))
Next
'1 获得图片2数据
W2 = Form1.ScaleX(P2W, vbHimetric, vbPixels)
H2 = Form1.ScaleY(P2H, 8, 3)
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = W2
.
biHeight = -H2
.biBitCount = 32
.biPlanes = 1
End With
ReDim zPic(3, W2 - 1, H2 - 1)
i = GetDIBits(PP.HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
Set P2 = Nothing
'2 获得图片1数据
W = Right
H = Bottom
With BI1.bmiHeader
.
biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
If RGB(zPic(2, 0, 0), zPic(1, 0, 0), z
Pic(0, 0, 0)) = RGB(zPic(2, W2 - 1, 0), zPic(1, W2 - 1, 0), zPic(0, W2 - 1, 0)) And _
RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, W2 - 1, H2 - 1), zPic(1, W2 - 1, H2 - 1), zPic(0, W2 - 1, H2 - 1)) And _
RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, 0, H2 - 1), zPic(1, 0, H2 - 1), zPic(0, 0, H2 - 1)) Then
R = zPic(2, 0, 0)
G = zPic(1, 0, 0)
b = zPic(0, 0, 0)
For J2 = 0 To H2 - 1 '左上角透明图
For I2 = 0 To W2 - 1
If zPic(2, I2, J2) = R Then GoTo NextLine: 'R
If zPic(1, I2, J2) = G Then GoTo NextLine: 'R
If zPic(0, I2, J2) = b Then GoTo NextLine: 'R
xx = I2
yy = J2
GoTo aac:
NextLine:
Next I2
Next J2
aac:
For J2 = H2 - 1 To yy Step -1 '右角透明图
For I2 = W2 - 1 To xx Step -1
If zPic(2, I2, J2) = R Then GoTo NextLine2: 'R
If zPic(1, I2, J2) = G Then GoTo NextLine2: 'R
If zPic(0, I2, J2) = b Then GoTo NextLine2: 'R
y1 = J2
GoTo aac2:
NextLine2:
Next I2
Next J2
aac2:
For I2 = W2 - 1 To yy Step -1 '下角透明图
For J2 = H2 - 1 To xx Step -1
If zPic(2, I2, J2) = R Then GoTo NextLine3: 'R
If zPic(1, I2, J2) = G Then GoTo NextLine3: 'R
If zPic(0, I2, J2) = b Then GoTo NextLine3: 'R
x1 = I2
GoTo aac3:
NextLine3:
Next J2
Next I2
aac3:
Else
xx = 0
yy = 0
x1 = W2
y1 = H2
R = G = b = -1
End If
bz = 0
ReDim fPic(3, W - 1, H - 1)
Dim hBMPhDC
Dim hDCmem As Long
Dim Pic1Handle As Long
Dim hBmpPrev As Long
hBMPhDC = GetDC(0)
'常规抓图代码，得到一个hBmp：
hDCmem = CreateCompatibleDC(hBMPhDC)
源代码1080p在线Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
'SelectObject hDCmem, hBmpPrev
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
For j = 0 To H - y1 - 2
For i = 0 To W - x1 - 2
s = 0
For J2 = yy To y1 - 2 '循环判断小图片
For I2 = xx To x1 - 2
If R = G = b = -1 Then
If fPic(2, i + I2, j + J2) < zPic(2, I2, J2) - RGB2(0) Or fPic(2, i + I2, j + J2) > zPic(2, I2, J2) + RGB2(0) Then GoTo ExitLine: 'R
If fPic(1, i + I2, j + J2) < zPic(1, I2, J2) - RGB2(1) Or fPic(1, i + I2, j + J2) > zPic(1, I2, J2) + RGB2(1) Then GoTo ExitLine: 'G
If fPic(0, i + I2, j + J2) < zPic(0, I2, J2) - RGB2(2) Or fPic(0, i + I2, j + J2) > zPic(0, I2, J2) + RGB2(2) Then GoTo ExitLine: 'B
Else
If fPic(2, i + I2, j + J2) < zPic(2, I2, J2) - RGB2(0) Or fPic(2, i + I2, j + J2) > zPic(2, I2, J2) + RGB2(0) And zPic(2, I2, J2) <> R Then GoTo ExitLine: 'R
If fPic(1, i + I2, j + J2) < zPic(1, I2, J2) - RGB2(1) Or fPic(1, i + I2, j + J2) > zPic(1, I2, J2) + RGB2(1) And zPic(1, I2, J2) <> G Then GoTo ExitLine: 'G
If fPic(0, i + I2, j + J2) < zPic(0, I2, J2) - RGB2(2) Or fPic(0, i + I2, j + J2) > zPic(0, I2, J2) + RGB2(2) And zPic(0, I2, J2) <> b Then GoTo ExitLine: 'B
End If
nc:
Next I2
Next J2
x = i + xx
y = j + yy
If FindPicE = "" Then
FindPicE = x & "," & y
Else
FindPicE = FindPicE
& x & "," & y
End If
ExitLine:
Next i
Next j
End Function
Public Function FindPicEx(Left As Long, Top As Long, Right As Long, Bottom As Long, Fileurl As String, delta_color As String) As String
Dim P2 As Picture, P2W, P2H, P2Handle
Dim s As Double
Dim bmp As BITMAP
Dim xx As Long, yy As Long, bz As Long, x1 As Long, y1 As Long
Dim m As Long
Dim W As Long, H As Long, i As Long, j As Long
Dim W2 As Long, H2 As Long, I2 As Long, J2 As Long
Dim RGB2(2) As Long
Dim zPic() As Byte, fPic() As Byte
Dim R As Long, G As Long, b As Long, x As Long, y As Long
Dim l() As String
Dim ld 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)
'常规抓图代码，得到一个hBmp：
hDCmem = CreateCompatibleDC(hBMPhDC)
Pic1Handle = CreateCompatibleBitmap(hBMPhDC, Right, Bottom)
hBmpPrev = SelectObject(hDCmem, Pic1Handle)
BitBlt hDCmem, 0, 0, Right, Bottom, hBMPhDC, Left, Top, SRCCOPY
'SelectObject hDCmem, hBmpPrev
DeleteDC hDCmem
i = GetDIBits(hBMPhDC, Pic1Handle, 0, H, fPic(0, 0, 0), BI1, 0)
ReleaseDC 0, hBMPhDC
l = Split(Fileurl, "|")
For ld = 0 To UBound(l)
If Load = "" Then
If Dir(Fileurl) = "" Then
MsgBox "This picture" & Fileurl & "cannot find, please confirm after path try again ! ", vbCritical, "ERR : Wrong !"
GoTo NextPicture:
End If
Set P2 = LoadPicture(l(ld))
Else
If Dir(Load & "\" & l(ld)) = "" Then
MsgBox "This picture" & Load & "\" & Fileurl & "cannot find, please confirm after path try again ! ", vbCritical, "ERR : Wrong !"
GoTo NextPicture:
End If
Set P2 = LoadPicture(Load & "\" & l(ld))
End If
P2W = P2.Width
P2H = P2.Height
P2Handle = P2.Handle
For m = 0 To 2
RGB2(m) = CLng("&H" & Mid(delta_color, m * 2 + 1, 2))
Next
'1 获得图片2数据
W2 = Form1.ScaleX(P2W, vbHimetric, vbPixels)
H2 = Form1.ScaleY(P2H, 8, 3)
With BI.bmiHeader
.biSize = Len(BI.bmiHeader)
.biWidth = W2
.biHeight = -H2
.biBitCount = 32
.biPlanes = 1
End With
ReDim zPic(3, W2 - 1, H2 - 1)
i = GetDIBits(PP.HDC, P2Handle, 0, H2, zPic(0, 0, 0), BI, 0)
Set P2 = Nothing
'2 获得图片1数据
W = Right
H = Bottom
With BI1.bmiHeader
.biSize = Len(BI1.bmiHeader)
.biWidth = W
.biHeight = -H
.biBitCount = 32
.biPlanes = 1
End With
If RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, W2 - 1, 0), zPic(1, W2 - 1, 0), zPic(0, W2 - 1, 0)) And _
RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, W2 - 1, H2 - 1), zPic(1, W2 - 1, H2 - 1), zPic(0, W2 - 1, H2 - 1)) And _
RGB(zPic(2, 0, 0), zPic(1, 0, 0), zPic(0, 0, 0)) = RGB(zPic(2, 0, H2 - 1), zPic(1, 0, H2 - 1), zPic(0, 0, H2 - 1)) Then
R = zPic(2, 0, 0)
G = zPic(1, 0, 0)
b = zPic(0, 0, 0)
For J2 = 0 To H2 - 1 '左上角透明图
For I2 = 0 To W2 - 1
If zPic(2, I2, J2) = R Then GoTo N

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。