Option Explicit
'* ************************************************************** *
'*    程序名称：form1.frm
'*    程序功能：快速比较两幅位图
'*    作者：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

'为了验证代码，故在窗体加载时自动生成两幅位图
Private Sub Form_Load()
    Dim Pic As PictureBox
   
    Me.ScaleMode = vbPixels
    Set Pic = Me.Controls.Add("VB.PictureBox", "Pic1") '动态加载PictureBox控件
    Pic.ScaleMode = vbPixels
    Pic.BorderStyle = 0
    Pic.Appearance = 0
    Pic.Move 0, 0, 100, 100 '设置PictureBox控件高度和宽度均为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,20)被忽略
    Pic.PSet (30, 30) '在坐标点(30,30)画一个点
    SavePicture Pic.Image, "c:/新圆.bmp" '保存为新圆
    Me.Controls.Remove "Pic1" '删除PictureBox控件
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.PictureBox", "OldPic") '动态增加一个PictureBox控件
    Set NewPic = Me.Controls.Add("VB.PictureBox", "NewPic") '动态增加一个PictureBox控件

Set OldPic = LoadPicture("c:/旧圆.bmp") '打开原始图像文件
    Set NewPic = LoadPicture("c:/新圆.bmp") '打开经过修改后的图像文件
   
    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位真彩色，此为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, c, 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位真彩色
            Dim OldData32() As Long
            Dim NewData32() As Long
            ReDim OldData32(c / 4 - 1) As Long
            ReDim NewData32(c / 4 - 1) As Long
            GetBitmapBits OldPic, c, OldData32(0)
            GetBitmapBits NewPic, c, 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