VB如何快带比较两幅位图

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

Option Explicit '* ************************************************************** * '* 程序<a href="https://www.jb51.cc/tag/mingcheng/" target="_blank" class="keywords">名称</a>：form1.frm '* 程序<a href="https://www.jb51.cc/tag/gongneng/" target="_blank" class="keywords">功能</a>：<a href="https://www.jb51.cc/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 G<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>bjectAPI Lib "gdi32" Alias "G<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>bjectA" (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 bmPla<a href="https://www.jb51.cc/tag/nes/" target="_blank" class="keywords">nes</a> As Integer bmBitsPixel As Integer bmBits As Long End Type '为了验证<a href="https://www.jb51.cc/tag/daima/" target="_blank" class="keywords">代码</a>，故在窗体加载时<a href="https://www.jb51.cc/tag/zidong/" target="_blank" class="keywords">自动</a><a href="https://www.jb51.cc/tag/shengcheng/" target="_blank" class="keywords">生成</a>两幅位图 Private Sub Form_Load() Dim Pic As Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a> Me.ScaleMode = vbPixels Set Pic = Me.Controls.Add("VB.Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>","Pic1") '动态加载Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>控件 Pic.ScaleMode = vbPixels Pic.BorderStyle = 0 Pic.Appe<a href="https://www.jb51.cc/tag/ara/" target="_blank" class="keywords">ara</a>nce = 0 Pic.Move 0,100,100 '设置Picture<a href="https://www.jb51.cc/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 '在控件上画<a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>正圆 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)画<a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>点 SavePicture Pic.Image,"c:/新圆.bmp" '保存为新圆 Me.Controls.Remove "Pic1" '<a href="https://www.jb51.cc/tag/shanchu/" target="_blank" class="keywords">删除</a>Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>控件 End Sub '点击按钮后开始进行图像比较 Private Sub Command1_Click() Dim OldPic As <a href="https://www.jb51.cc/tag/stdole/" target="_blank" class="keywords">stdole</a>.IPicture<a href="https://www.jb51.cc/tag/dis/" target="_blank" class="keywords">dis</a>p Dim NewPic As <a href="https://www.jb51.cc/tag/stdole/" target="_blank" class="keywords">stdole</a>.IPicture<a href="https://www.jb51.cc/tag/dis/" target="_blank" class="keywords">dis</a>p 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="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>","OldPic") '动态<a href="https://www.jb51.cc/tag/zengjia/" target="_blank" class="keywords">增加</a><a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>控件 Set NewPic = Me.Controls.Add("VB.Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>","NewPic") '动态<a href="https://www.jb51.cc/tag/zengjia/" target="_blank" class="keywords">增加</a><a href="https://www.jb51.cc/tag/yige/" target="_blank" class="keywords">一个</a>Picture<a href="https://www.jb51.cc/tag/Box/" target="_blank" class="keywords">Box</a>控件 Set OldPic = LoadPicture("c:/旧圆.bmp") '打开原始图像<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> Set NewPic = LoadPicture("c:/新圆.bmp") '打开经过<a href="https://www.jb51.cc/tag/xiugai/" target="_blank" class="keywords">修改</a>后的图像<a href="https://www.jb51.cc/tag/wenjian/" target="_blank" class="keywords">文件</a> G<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>bjectAPI OldPic,Len(OldPicInfo),OldPicInfo '获得图像有关信息 G<a href="https://www.jb51.cc/tag/eto/" target="_blank" class="keywords">eto</a>bjectAPI 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="https://www.jb51.cc/tag/caise/" target="_blank" class="keywords">彩色</a>，此为VB<a href="https://www.jb51.cc/tag/mo/" target="_blank" class="keywords">默</a>认位图格式 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="https://www.jb51.cc/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 = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> Set NewPic = <a href="https://www.jb51.cc/tag/nothing/" target="_blank" class="keywords">nothing</a> End Sub