VB如何快带比较两幅位图

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

Option Explicit '* ************************************************************** * '* 程序名称：form1.frm '* 程序功能：快速比较两幅位图 '* 作者：lyserver '* 联系方式：http://blog.youkuaiyun.com/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