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, 0&)
    Call SelectObject(hdc, pic.Handle)
    
    Dim bits() As Byte
    ReDim bits(3, w, h) As Byte
    Dim bi As BitMapInfo
    With bi.bmiHeader
        .biBitCount = 32&
        .biCompression = 0&
        .biPlanes = 1&
        .biSize = Len(bi.bmiHeader)
        .biWidth = w
        .biHeight = h
    End With
    Call GetDIBits(hdc, pic.Handle, 0, h, bits(0, 0, 0), bi, 0&)
    
    ‘灰度化
    Dim x As Long
    Dim y As Long
    Dim g As Byte
    For x = 0 To w
        For y = 0 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(0, x, y) * 0.114 + bits(1, x, y) * 0.587 + bits(2, x, y) * 0.299
            bits(0, x, y) = g
            bits(1, x, y) = g
            bits(2, x, y) = g
        Next
    Next
    

    
    Picture1.Picture = Picture1.Image
    Call SetDIBits(Picture1.hdc, Picture1.Picture.Handle, 0&, h, bits(0, 0, 0), bi, 0&)
    Picture1.Picture = Picture1.Image
    
    Dim threshold As Byte
    threshold = GetThreshold(bits, w, h)
    
    ‘二值化，阈值通过[最大类间方差法(Otsu)]取得
    For x = 0 To w
        For y = 0 To h
            If bits(0, x, y) > threshold Then
                bits(0, x, y) = 255
                bits(1, x, y) = 255
                bits(2, x, y) = 255
            Else
                bits(0, x, y) = 0
                bits(1, x, y) = 0
                bits(2, x, y) = 0
            End If
        Next
    Next

    Picture2.Picture = Picture2.Image
    Call SetDIBits(Picture2.hdc, Picture2.Picture.Handle, 0&, h, bits(0, 0, 0), bi, 0&)
    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(255) As Long
    Dim x As Long
    Dim y As Long
    Dim i As Long
    
    For i = 0 To 255: hist(i) = 0: Next
    For y = 0 To Height
        For x = 0 To Width
            hist(Pixels(0, x, y)) = hist(Pixels(0, x, y)) + 1
        Next
    Next
    
    Dim p(255) 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 = 0
    For i = 0 To 255
        p(i) = hist(i) / total
        ut = ut + i * hist(i)
    Next
    ut = ut / total
    wk = 0
    uk = 0
    maxs = 0
    For i = 0 To 255
        uk = uk + i * p(i)
        wk = wk + p(i)
        If wk <= EPSTLON Or wk >= (1# - EPSTLON) Then
        Else
            sigma = (ut * wk - uk)
            sigma = (sigma * sigma) / (wk * (1# - wk))
            If sigma > maxs Then
                maxs = sigma
                maxk = i
            End If
        End If
    Next
    GetThreshold = maxk
End Function