vb中的图像匹配。

Question

前几天导师接了个课题，要用图象处理来测量量杯中液体的高度（图片质量比较低，难以直接读数）真是忙死小弟了，开始用一种简单的方法对于大多数图片效果都还不错，但十几张图片总有那门1个是错误的，后来有同学提议用图象匹配的方法来试一试，可是现场规定必须用VB，哎，没有办法啊，用VB做图象处理，大家知道的，速度........。不管怎么样，还是搞出来了，匹配的效果还可以。当然，有效果就一定要和大家一起共享喜悦。
    代码里面有许多地方都值得改进（没有学过软件工程啊），我自己也感觉到很多地方冗余，希望各位高手指教。
    感觉不好的地方：
    （1） Readpic和Showpic两个函数应该可以合并成一个，毕竟里面大部分代码都是一样的。
    （2） 速度应该还可以提高。

Answer 1

模块中
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Const SRCCOPY = &HCC0020Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End TypeType BITMAPINFOHEADER              '40 bytes
   biSize As Long                  'BITMAPINFOHEADER结构的大小
   biWidth As Long
   biHeight As Long
   biPlanes As Integer             '设备的为平面数，现在都是1
   biBitCount As Integer           '图像的颜色位图
   biCompression As Long           '压缩方式
   biSizeImage As Long             '实际的位图数据所占字节
   biXPelsPerMeter As Long         '目标设备的水平分辨率
   biYPelsPerMeter As Long         '目标设备的垂直分辨率
   biClrUsed As Long               '使用的颜色数
   biClrImportant As Long          '重要的颜色数。如果该项为0，表示所有颜色都是重要的
End Type
  
Type RGBQUAD                        ' 只有bibitcount为1，2，4时才有调色板
   rgbBlue As Byte                  '蓝色分量
   rgbGreen As Byte                 '绿色分量
   rgbRed As Byte                   '红色分量
   rgbReserved As Byte              '保留值
End TypeType BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0&
Private Const LR_LOADFROMFILE = &H10
Private Const IMAGE_BITMAP = 0&
Private PicInfo As BITMAP         '定义位图信息结构
Private DIBInfo As BITMAPINFO     'Device Ind. Bitmap info structure
Public iDATA() As Byte
Public bDATA() As Byte            '位图信息

Answer 2

接上 
'pic待读取数据位图，data保存图象数据
Public Sub ReadPic(ByVal pic As Long, data() As Byte)   '读取位图数据
  Dim hdcNew As Long
  Dim oldhand As Long
  Dim ret As Long
  Dim BytesPerScanLine As Long    '一个扫描行的长度
  Dim PadBytesPerScanLine As Long
  Call GetObject(pic, Len(PicInfo), PicInfo)         '取得对指定对象进行说明的一个结构，hobject为位图，刷子等的句柄，
                                                      'count欲取回的字节数。通常是由lpObject定义的那个结构的长度
  hdcNew = CreateCompatibleDC(0&)                    '创建一个与屏幕兼容的设备场景
  oldhand = SelectObject(hdcNew, pic)
  With DIBInfo.bmiHeader
    .biSize = 40                                       'bmp3.0
    .biWidth = PicInfo.bmWidth
    .biHeight = -PicInfo.bmHeight     '从下往上扫描
    .biPlanes = 1
    .biBitCount = 32                 '32位位图，默认情况下Windows不会处理最高8位，可以将它作为自己的Alpha通道
    .biCompression = BI_RGB          '无压缩
    BytesPerScanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)  '一个扫描行的长度，是4的倍数。
    PadBytesPerScanLine = _
    BytesPerScanLine - (((.biWidth * .biBitCount) + 7) \ 8)
    .biSizeImage = BytesPerScanLine * Abs(.biHeight)
  End With
  ReDim data(1 To 4, 1 To PicInfo.bmWidth, 1 To PicInfo.bmHeight) As Byte
  ret = GetDIBits(hdcNew, pic, 0, PicInfo.bmHeight, data(1, 1, 1), DIBInfo, DIB_RGB_COLORS)
                   '将来自一幅位图的二进制位复制到一幅与设备无关的位图里
              ' 该函数利用申请到的内存，由GDI位图得到DIB位图数据，可以对DIB的格式进行控制，通过该函数，
                '可以制定颜色的位数，而且可以指定是否进行压缩。如果采用了压缩方式，则必须调用该函数两次，
                '一次为了得到所需内存，另外一次为了得到位图数据
                '定义了与设备有关位图hBitmap的配置信息的一个设备场景的句柄
                'hbmp 源位图的句柄
                'uStartScan为欲复制到dib中的第一条扫描线的位置
                'cScanLines欲复制的扫描先的数量
                'ipvbits 指向一个缓冲区的指针
                '指向BITMAPINF，对DIB的格式及颜色进行说明的一个结构。
                '颜色表包含了RGB颜色
                'idata(1,x,y)表示b的颜色
   SelectObject hdcNew, oldhand
   DeleteDC hdcNew
End Sub
Public Sub ShowPic(ByVal pic As Long, data() As Byte)  '显示位图
  Dim hdcNew As Long
  Dim oldhand As Long
  Dim ret As Long
  Dim BytesPerScanLine As Long    '一个扫描行的长度
  Dim PadBytesPerScanLine As Long
  Call GetObject(pic, Len(PicInfo), PicInfo)         '取得对指定对象进行说明的一个结构，hobject为位图，刷子等的句柄，
                                                      'count欲取回的字节数。通常是由lpObject定义的那个结构的长度
  hdcNew = CreateCompatibleDC(0&)                    '创建一个与屏幕兼容的设备场景
  oldhand = SelectObject(hdcNew, pic)
  With DIBInfo.bmiHeader
    .biSize = 40                                       'bmp3.0
    .biWidth = PicInfo.bmWidth
    .biHeight = -PicInfo.bmHeight     '从下往上扫描
    .biPlanes = 1
    .biBitCount = 32                 '32位位图，默认情况下Windows不会处理最高8位，可以将它作为自己的Alpha通道
    .biCompression = BI_RGB          '无压缩
    BytesPerScanLine = ((((.biWidth * .biBitCount) + 31) \ 32) * 4)  '一个扫描行的长度，是4的倍数。
    PadBytesPerScanLine = _
    BytesPerScanLine - (((.biWidth * .biBitCount) + 7) \ 8)
    .biSizeImage = BytesPerScanLine * Abs(.biHeight)
  End With
  ret = SetDIBits(hdcNew, pic, 0, PicInfo.bmHeight, data(1, 1, 1), DIBInfo, DIB_RGB_COLORS)
  SelectObject hdcNew, oldhand
  DeleteDC hdcNew
  Form1.Picture1.Refresh
End Sub
'Lwidth目标图象宽度，lheight目标图象高度
'temph为匹配图象的高度，tempw为匹配图象的宽度Public Sub TemplateMatchDib(Lwidth As Long, Lheight As Long, Temph As Long, Tempw As Long)
Dim i As Integer, j As Integer, m As Integer, n As Integer
Dim dsigmast As Double, dsigmas As Double, dsigmat As Double, r As Double
Dim LmaxWidth As Long, LmaxHeight As Long
Dim MidMatrix() As Long
ReDim MidMatrix(3, Lwidth, Lheight) As LongOn Error Resume Next
For i = 1 To Lwidth
    For j = 1 To Lheight
       For m = 1 To 3   '处理的是24位位图，可选择处理灰度图，速度会快一些
          MidMatrix(m, i, j) = 255   '初始化中间矩阵
       Next m
    Next j
Next i
dsigmat = 0
For n = 1 To Temph - 1
    For m = 1 To Tempw - 1
       dsigmat = dsigmat + Val(bDATA(1, m, n)) ^ 2   '计算dsigmat
    Next m
Next n
maxr = 0
For j = 1 To Lheight - Temph + 1 Step 3    '找到图象中最大相似性出现的位置
      For i = 1 To Lwidth - Tempw + 1 Step 3  '此初的step改为1似乎对结果没什么影响，为3可提高速度
         dsigmast = 0
         dsigmas = 0    '归0
         For n = 1 To Temph
            For m = 1 To Tempw
                dsigmas = dsigmas + (Val(iDATA(1, i + m - 1, j + n - 1)) + Val(iDATA(2, i + m - 1, j + n - 1)) + Val(iDATA(3, i + m - 1, j + n - 1)) / 3) ^ 2
                dsigmast = dsigmast + (Val(iDATA(1, i + m - 1, j + n - 1)) + Val(iDATA(2, i + m - 1, j + n - 1)) + Val(iDATA(3, i + m - 1, j + n - 1)) / 3) * (Val(bDATA(1, m, n)) + Val(bDATA(1, m, n)) + Val(bDATA(1, m, n))) / 3
            Next m
         Next n
         r = dsigmast / (Sqr(dsigmas) * Sqr(dsigmat))  '计算相似性
         If r > maxr Then    '与最大相似性比较
            maxr = r
            LmaxWidth = i
            LmaxHeight = j
         End If
     Next i
Next j
   For n = 1 To Temph   '将最大相似性出现的区域部分复制到目标图象
      For m = 1 To Tempw
          MidMatrix(1, m + LmaxWidth, n + LmaxHeight) = bDATA(1, m, n)
          MidMatrix(2, m + LmaxWidth, n + LmaxHeight) = bDATA(2, m, n)
          MidMatrix(3, m + LmaxWidth, n + LmaxHeight) = bDATA(3, m, n)
       Next m
 Next n
      
For i = 1 To Lwidth
   For j = 1 To Lheight
       For m = 1 To 3
           iDATA(m, i, j) = MidMatrix(m, i, j)
       Next m
   Next j
Next i
End Sub

Answer 3

窗体中，两个picturebox ,一个command按钮
Private Sub Command1_Click()
Picture1.ScaleMode = 3
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture2.ScaleMode = 3
Picture2.AutoRedraw = True
Picture2.AutoSize = True
If Picture2.ScaleWidth > Picture2.ScaleWidth Or Picture2.ScaleHeight > Picture2.ScaleHeight Then
  MsgBox "图象大小不符合要求"
  Exit Sub
End If
Call ReadPic(Picture1.Image, iDATA())
Call ReadPic(Picture2.Image, bDATA())
Call TemplateMatchDib(Picture1.ScaleWidth, Picture1.ScaleHeight, Picture2.ScaleHeight, Picture2.ScaleWidth)
Call ShowPic(Picture1.Image, iDATA)
End Sub

Answer 4

hehe,收藏，说不定有用的着的时候呢

Answer 5

速度不怎么样，不过已经用了DIB

Answer 6

经过实践我发现这是一个误区，用DIB并不代表速度就快，相反，DDB到DIB及DIB到DDB的转换反而会很耗时，要想高速，DDB处理远快于DIB，用GetBitmapBits及SetBitmapBits可省去转换的时间，不过这有个不方便之处，就是受设备影响大，你必须分别针对1、4、8、16、24、32等色深的情况，写出不同的处理代码。
楼主的代码我没细看，但好象有个漏洞，就是没看你进行DDB到DIB的转换，就用GetDIBits获取数据了，如果Pic正好是与你DIBInfo定义的相同的32位色位图，这样做可能没明显问题，但如果不是，可就麻烦了，会崩溃的，你试试将显示器属性改为16位色看看。

Answer 7

谢谢建议，以前用过DDB，但是会出现这次可以运行，而下次又不行了这种情况。

Answer 8

楼主的READ和SHOW两个函数没有什么好看，这两个东西的速度也不是VB说了算的。
主要是TemplateMatchDib这个函数上，觉得有很多地方可以优化的。特别是：Val(iDATA（1,x,y））（类型转换？？）和里面的一些除法和^2的运算，感觉会很慢。建议楼主将整个运算的代数式进行优化，所有可以预先算好的东西都放在循环外部。因为不知道楼主的算法，这里也就不多罗嗦了。