VB6 大图中找小图的纯代码今天 13:28
用记事本打开frmMain.frm，代码：
VERSION 5.00
Begin VB.Form frmMain
Caption = "Form1"
ClientHeight = 10020
ClientLeft = 120
ClientTop = 450
ClientWidth = 13260
LinkTopic = "Form1"
ScaleHeight = 668
ScaleMode = 3 'Pixel
ScaleWidth = 884
StartUpPosition = 3 '窗口缺省
Begin VB.PictureBox Picture2
Height = 975
Left = 360
ScaleHeight = 61
ScaleMode = 3 'Pixel
ScaleWidth = 77
TabIndex = 4
Top = 960
Width = 1215
End
Begin VB.CommandButton Command3
Caption = "开始查找"
Height = 495
Left = 3720
TabIndex = 3
Top = 120
Width = 1215
End
Begin VB.CommandButton Command2
Caption = "加载小图"
Height = 495
Left = 2040
TabIndex = 2
Top = 120
Width = 1215
End
Begin VB.CommandButton Command1
Caption = "加载大图"
Height = 495
Left = 480
TabIndex = 1
Top = 120
Width = 1215
End
Begin VB.PictureBox Picture1
AutoSize = -1 'True
Height = 9255
Left = 120
ScaleHeight = 613
ScaleMode = 3 'Pixel
ScaleWidth = 985
TabIndex = 0
Top = 840
Width = 14835
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim cPicData As clsPic
Dim cPicData2 As clsPic
Private Sub Command1_Click()
If cPicData.LoadFile(App.Path & "\大图.bmp") Then
Picture1.Picture = LoadPicture(App.Path & "\大图.bmp")
End If
End Sub
Private Sub Command2_Click()
If cPicData2.LoadFile(App.Path & "\小图.bmp") Then
Picture2.Picture = LoadPicture(App.Path & "\小图.bmp")
'cPicData2.Darw Picture2.hDC
End If
End Sub
Private Sub Command3_Click()
Dim pic1$, w1&, h1&, pic2$, w2&, h2&, StartTime&
StartTime = GetTickCount
With cPicData
If .IsLoad Then
pic1 = .StrPix
w1 = .Width
h1 = .Height
Else
Exit Sub
End If
End With
With cPicData2
If .IsLoad Then
pic2 = .StrPix
w2 = .Width
h2 = .Height
Else
Exit Sub
End If
End With
Dim strFirst$, strNext$, i&, Pos&, FirstPos&, h&, FindTime&, Flag As Boolean
strFirst = MidB(pic2, 1, w2 * 4)
For i = 1 To LenB(pic1)
FirstPos = InStrB(i, pic1, strFirst) '查找小图第一行
If FirstPos ＞ 0 Then
' For h = 1 To h2'读取小图第二行继续查找
' strNext = MidB(pic2, h * w2 * 4 + 1, w2 * 4)
' Next
'
' If Flag Then
y = Int(FirstPos / w1 / 4)
x = (FirstPos Mod (w1 * 4)) / 4
FindTime = GetTickCount - StartTime
MsgBox "查找用时(ms)：" & FindTime & " 找到坐标： x=" & x & ",y=" & y
Picture1.Line (x, y)-Step(w2, h2), RGB(255, 0, 0), B
Debug.Print "ok", p, x, y
Exit For
' End If
End If
Next
End Sub
Private Sub Form_Load()
Set cPicData = New clsPic
Set cPicData2 = New clsPic
End Sub
Private Sub Form_Unload(Cancel%)
Set cPicData = Nothing
Set cPicData2 = Nothing
End Sub新建类 clsPic.cls，代码：
'excelHome论坛找了一段大图查找代码，修改了一下
Option Explicit
'声明矩形数据类型
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'Private Const SM_CXSCREEN = 0 'X Size of screen
'Private Const SM_CYSCREEN = 1 'Y Size of Screen
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) 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 GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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
Private Declare Function GetGDIObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef 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 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
Dim mArrData() As Byte
Dim mWidth&
Dim mHeight&
Dim mFlagLoad As Boolean
Public Property Get IsLoad() As Boolean
IsLoad = mFlagLoad
End Property
Public Property Get Width&()
Width = mWidth
End Property
Public Property Get Height&()
Height = mHeight
End Property
Public Property Get ArrPix() As Byte()
ArrPix = mArrData
End Property
Public Property Get StrPix$()
StrPix = mArrData
End Property
Public Sub CopyImgPixData(address&)
Dim Length&
Length = mWidth * mHeight * 4 - 1
CopyMemory ByVal address, mArrData(0), Length
End Sub
Public Function LoadFile(FilePath As String) As Boolean
Dim PicSrc As StdPicture
mWidth = 0
mHeight = 0
Erase mArrData
mFlagLoad = False
Set PicSrc = LoadPicture(FilePath)
Call PictureToPixel(PicSrc, mArrData, mWidth, mHeight)
LoadFile = True
mFlagLoad = True
End Function
'*******************内部********************
Private Function PictureToPixel(PicSrc As StdPicture, BmpPix() As Byte, BmpWidth As Long, BmpHeight As Long) As Boolean
Dim hBMPhDC&, hDCmem&
Dim BIINF As BitmapInfo
Dim Bmp As Bitmap
Dim lrtn&
GetGDIObject PicSrc.Handle, Len(Bmp), Bmp
BmpWidth = Bmp.bmWidth
BmpHeight = Bmp.bmHeight
With BIINF.bmiHeader
.biSize = Len(BIINF.bmiHeader)
.biWidth = BmpWidth
.biHeight = -BmpHeight
.biBitCount = 32
.biPlanes = 1
End With
ReDim BmpPix(BmpWidth * 4 * BmpHeight - 1)
hBMPhDC = GetDC(0) '使用屏幕hdc
hDCmem = CreateCompatibleDC(hBMPhDC)
lrtn = GetDIBits(hDCmem, PicSrc.Handle, 0&, BmpHeight, BmpPix(0), BIINF, 0)
ReleaseDC 0, hBMPhDC
End Function
全部回复（0）