VB如何快带比较两幅位图

@H_502_0@ 虽然VB可以使用Point函数或API函数GetPiexl获得像素颜色，但速度较慢，同时，CSDN论坛里有几个朋友提出了图像比较的问题，为此，写了以下代码，希望能给有此需要的朋友一些启发：

@H_502_0@

Option Explicit
'* ************************************************************** *
'*    程序<a href="/tag/mingcheng/" target="_blank" class="keywords">名称</a>：form1.frm
'*    程序<a href="/tag/gongneng/" target="_blank" class="keywords">功能</a>：<a href="/tag/kuaisu/" target="_blank" class="keywords">快速</a>比较两幅位图
'*    作者：lyserver
'*    联系方式：http://blog.csdn.net/lyserver
'* ************************************************************** *
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long,ByVal dwCount As Long,lpBits As Any) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long,ByVal nCount As Long,lpObject As Any) As Long
Private Type BITMAP '14 bytes
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type

'为了验证<a href="/tag/daima/" target="_blank" class="keywords">代码</a>，故在窗体加载时<a href="/tag/zidong/" target="_blank" class="keywords">自动</a><a href="/tag/shengcheng/" target="_blank" class="keywords">生成</a>两幅位图
Private Sub Form_Load()
    Dim Pic As Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>
    
    Me.ScaleMode = vbPixels
    Set Pic = Me.Controls.Add("VB.Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>","Pic1") '动态加载Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>控件
    Pic.ScaleMode = vbPixels
    Pic.BorderStyle = 0
    Pic.Appearance = 0
    Pic.Move 0,100,100 '设置Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>控件高度和宽度均为100,左下角(100,100)将被忽略
    Pic.AutoRedraw = True
    Pic.Circle (Pic.ScaleWidth / 2,Pic.ScaleWidth / 2),Pic.ScaleWidth / 2 '在控件上画一个正圆
    SavePicture Pic.Image,"c:/旧圆.bmp"  '保存为旧圆
    Pic.Line (0,0)-(20,0) '从(0,0)到(20,0)画一条水平直线,终端点(20,0)被忽略
    Pic.Line (10,10)-(20,20) '从(10,10)到(20,20)画一第斜线,20)被忽略
    Pic.PSet (30,30) '在坐标点(30,30)画一个点
    SavePicture Pic.Image,"c:/新圆.bmp" '保存为新圆
    Me.Controls.Remove "Pic1" '<a href="/tag/shanchu/" target="_blank" class="keywords">删除</a>Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>控件
End Sub

'点击按钮后开始进行图像比较
Private Sub Command1_Click()
    Dim OldPic As stdole.IPictureDisp
    Dim NewPic As stdole.IPictureDisp
    Dim OldPicInfo As BITMAP,NewPicInfo As BITMAP
    Dim i As Long,j As Long,k As Long,c As Long

Set OldPic = Me.Controls.Add("VB.Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>","OldPic") '动态<a href="/tag/zengjia/" target="_blank" class="keywords">增加</a>一个Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>控件
    Set NewPic = Me.Controls.Add("VB.Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>","NewPic") '动态<a href="/tag/zengjia/" target="_blank" class="keywords">增加</a>一个Picture<a href="/tag/Box/" target="_blank" class="keywords">Box</a>控件

Set OldPic = LoadPicture("c:/旧圆.bmp") '打开原始图像<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>
    Set NewPic = LoadPicture("c:/新圆.bmp") '打开经过<a href="/tag/xiugai/" target="_blank" class="keywords">修改</a>后的图像<a href="/tag/wenjian/" target="_blank" class="keywords">文件</a>
    
    GetObjectAPI OldPic,Len(OldPicInfo),OldPicInfo '获得图像有关信息
    GetObjectAPI NewPic,Len(NewPicInfo),NewPicInfo
    
    If OldPicInfo.bmBitsPixel <> NewPicInfo.bmBitsPixel Or OldPicInfo.bmWidth <> NewPicInfo.bmWidth Or _
        OldPicInfo.bmHeight <> OldPicInfo.bmHeight Then Exit Sub '如果两幅位图大小和颜色深度不一样则取消比较
    
    c = OldPicInfo.bmWidthBytes * OldPicInfo.bmHeight '获得图像数据字节数
    Select Case OldPicInfo.bmBitsPixel '根据图像颜色深度分别处理
        Case 24 '比较24位真<a href="/tag/caise/" target="_blank" class="keywords">彩色</a>，此为VB默认位图格式
            Dim OldData24() As Byte
            Dim NewData24() As Byte
            ReDim OldData24(c - 1) As Byte
            ReDim NewData24(c - 1) As Byte
            GetBitmapBits OldPic,c,OldData24(0)
            GetBitmapBits NewPic,NewData24(0)
            For i = 0 To OldPicInfo.bmHeight - 1 '垂直坐标
                For j = 0 To OldPicInfo.bmWidth - 1 '水平坐标
                    k = i * OldPicInfo.bmWidthBytes + j * 3
                    If OldData24(k) <> NewData24(k) Or OldData24(k + 1) <> NewData24(k + 1) Or _
                        OldData24(k + 2) <> NewData24(k + 2) Then
                        Debug.Print "第" & i & "行第" & j & "列像素值不同"
                    End If
                Next
            Next
            Erase OldData24
            Erase NewData24
        Case 32 '比较32位真<a href="/tag/caise/" target="_blank" class="keywords">彩色</a>
            Dim OldData32() As Long
            Dim NewData32() As Long
            ReDim OldData32(c / 4 - 1) As Long
            ReDim NewData32(c / 4 - 1) As Long
            GetBitmapBits OldPic,OldData32(0)
            GetBitmapBits NewPic,NewData32(0)
            For i = 0 To OldPicInfo.bmHeight - 1 '垂直坐标
                For j = 0 To OldPicInfo.bmWidth - 1 '水平坐标
                    k = i * OldPicInfo.bmWidthBytes + j
                    If OldData32(k) <> NewData32(k) Then
                        Debug.Print "第" & i & "行第" & j & "列像素值不同"
                    End If
                Next
            Next
            Erase OldData32
            Erase NewData32
        Case Else '其它格式暂不处理
    End Select
    Me.Controls.Remove "OldPic"
    Me.Controls.Remove "NewPic"
    Set OldPic = Nothing
    Set NewPic = Nothing
End Sub

VB如何快带比较两幅位图

猜你在找的VB相关文章