VB6之图像灰度与二值化

老代码备忘，我对图像处理不是太懂。

注：部分代码引援自网上，话说我到底自己写过什么代码。。。

 Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hbitmap As Long, _
     ByVal dwCount As Long, _
     lpBits As Any) As Long
 Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hbitmap As Long, _
     ByVal dwCount As Long, _
     lpBits As Any) 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 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 Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
     ByVal hObject As Long) As Long
 Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _
     ByVal lpDeviceName As String, _
     ByVal lpOutput As String, _
     lpInitData As Long) As Long
 Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

 Private Type BitMapInfoHeader
     biSize As Long
     biWidth As Long
     biHeight As Long
     biPlanes As Integer
     biBitCount As Integer
     biCompression As Long
     biSizeImage As Long
     biXPelsPerMeter As Long
     biYPelsPerMeter As Long
     biClrUsed As Long
     biClrImportant As Long
 End Type

 Private Type RGBQuad
     rgbBlue As Byte
     rgbGreen As Byte
     rgbRed As Byte
     ''rgbReserved As Byte
 End Type

 Private Type BitMapInfo
     bmiHeader As BitMapInfoHeader
     bmiColors As RGBQuad
 End Type

 Private Sub Command1_Click()
     Dim pic As StdPicture
     Set pic = LoadPicture("D:\My Documents\Downloads\119562132_21n.jpg")

     Dim w As Long
     Dim h As Long
     With pic
         w = ScaleX(.Width, vbHimetric, vbPixels)
         h = ScaleY(.Height, vbHimetric, vbPixels)
     End With

     Dim hdc As Long
     hdc = CreateDC("DISPLAY", vbNullString, vbNullString, &)
     Call SelectObject(hdc, pic.Handle)

     Dim bits() As Byte
     ReDim bits(, w, h) As Byte
     Dim bi As BitMapInfo
     With bi.bmiHeader
         .biBitCount = &
         .biCompression = &
         .biPlanes = &
         .biSize = Len(bi.bmiHeader)
         .biWidth = w
         .biHeight = h
     End With
     Call GetDIBits(hdc, pic.Handle, , h, bits(, , ), bi, &)

     '灰度化
     Dim x As Long
     Dim y As Long
     Dim g As Byte
     For x =  To w
         For y =  To h
             '灰度公式：Gray=R×0.299+G×0.587+B×0.114
             '貌似有更好的方案：g=(bits(0, ix, iy) ^ 2.2 * 0.0722 + bits(1, ix, iy) ^ 2.2 * 0.7152 + bits(2, ix, iy) ^ 2.2 * 0.2126) ^ (1 / 2.2)
             '不过，肉眼看不出差别来 (>_<)
             g = bits(, x, y) * 0.114 + bits(, x, y) * 0.587 + bits(, x, y) * 0.299
             bits(, x, y) = g
             bits(, x, y) = g
             bits(, x, y) = g
         Next
     Next

     Picture1.Picture = Picture1.Image
     Call SetDIBits(Picture1.hdc, Picture1.Picture.Handle, &, h, bits(, , ), bi, &)
     Picture1.Picture = Picture1.Image

     Dim threshold As Byte
     threshold = GetThreshold(bits, w, h)

     '二值化，阈值通过[最大类间方差法(Otsu)]取得
     For x =  To w
         For y =  To h
             If bits(, x, y) > threshold Then
                 bits(, x, y) =
                 bits(, x, y) =
                 bits(, x, y) =
             Else
                 bits(, x, y) =
                 bits(, x, y) =
                 bits(, x, y) =
             End If
         Next
     Next

     Picture2.Picture = Picture2.Image
     Call SetDIBits(Picture2.hdc, Picture2.Picture.Handle, &, h, bits(, , ), bi, &)
     Picture2.Picture = Picture2.Image

     Erase bits
     Call DeleteDC(hdc)
     Set pic = Nothing
 End Sub

 Private Function GetThreshold(ByRef Pixels() As Byte, _
     ByVal Width As Long, _
     ByVal Height As Long) As Byte
     '最大类间方差法(Otsu)
     '这个函数是我根据百度文库一个文档里提供的C代码翻译过来的
     '@http://wenku.baidu.com/link?url=wVl9A7eZiRddxpaCPPLcAIb-VDlyrV__-Zfw6j6o50FEUochgV9G_zRVsMHVDxN2ilOUXiRbSSM-as_ELJpjxnWEvERlABlvVoVK6-FDQpW
     Dim hist() As Long
     Dim x As Long
     Dim y As Long
     Dim i As Long

     For i =  To : hist(i) = : Next
     For y =  To Height
         For x =  To Width
             hist(Pixels(, x, y)) = hist(Pixels(, x, y)) +
         Next
     Next

     Dim p() As Double
     Dim ut As Double
     Dim uk As Double
     Dim sigma As Double
     Dim mk As Double
     Dim maxk As Byte
     Dim maxs As Double
     Dim total As Long
     Dim EPSTLON As Double
     EPSILON = 0.000001 '10 ^ -6

     total = Width * Height
     ut =
     For i =  To
         p(i) = hist(i) / total
         ut = ut + i * hist(i)
     Next
     ut = ut / total
     wk =
     uk =
     maxs =
     For i =  To
         uk = uk + i * p(i)
         wk = wk + p(i)
         If wk <= EPSTLON Or wk >= (# - EPSTLON) Then
         Else
             sigma = (ut * wk - uk)
             sigma = (sigma * sigma) / (wk * (# - wk))
             If sigma > maxs Then
                 maxs = sigma
                 maxk = i
             End If
         End If
     Next
     GetThreshold = maxk
 End Function

上张图，看看效果：

原图：