VB6之图像灰度与二值化
老代码备忘，我对图像处理不是太懂。
注：部分代码引援自网上，话说我到底自己写过什么代码。。。
1 Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hbitmap As Long, _ 2 ByVal dwCount As Long, _ 3 lpBits As Any) As Long 4 Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hbitmap As Long, _ 5 ByVal dwCount As Long, _ 6 lpBits As Any) As Long 7 Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, _ 8 ByVal hbitmap As Long, _ 9 ByVal nStartScan As Long, _ 10 ByVal nNumScans As Long, _ 11 lpBits As Any, _ 12 lpBI As BitMapInfo, _ 13 ByVal wUsage As Long) As Long 14 Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, _ 15 ByVal hbitmap As Long, _ 16 ByVal nStartScan As Long, _ 17 ByVal nNumScans As Long, _ 18 lpBits As Any, _ 19 lpBI As BitMapInfo, _ 20 ByVal wUsage As Long) As Long 21 Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _ 22 ByVal hObject As Long) As Long 23 Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _ 24 ByVal lpDeviceName As String, _ 25 ByVal lpOutput As String, _ 26 lpInitData As Long) As Long 27 Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long 28 29 Private Type BitMapInfoHeader 30 biSize As Long 31 biWidth As Long 32 biHeight As Long 33 biPlanes As Integer 34 biBitCount As Integer 35 biCompression As Long 36 biSizeImage As Long 37 biXPelsPerMeter As Long 38 biYPelsPerMeter As Long 39 biClrUsed As Long 40 biClrImportant As Long 41 End Type 42 43 Private Type RGBQuad 44 rgbBlue As Byte 45 rgbGreen As Byte 46 rgbRed As Byte 47 ''rgbReserved As Byte 48 End Type 49 50 Private Type BitMapInfo 51 bmiHeader As BitMapInfoHeader 52 bmiColors As RGBQuad 53 End Type 54 55 Private Sub Command1_Click() 56 Dim pic As StdPicture 57 Set pic = LoadPicture("D:\My Documents\Downloads\119562132_21n.jpg") 58 59 Dim w As Long 60 Dim h As Long 61 With pic 62 w = ScaleX(.Width, vbHimetric, vbPixels) 63 h = ScaleY(.Height, vbHimetric, vbPixels) 64 End With 65 66 Dim hdc As Long 67 hdc = CreateDC("DISPLAY", vbNullString, vbNullString, 0&) 68 Call SelectObject(hdc, pic.Handle) 69 70 Dim bits() As Byte 71 ReDim bits(3, w, h) As Byte 72 Dim bi As BitMapInfo 73 With bi.bmiHeader 74 .biBitCount = 32& 75 .biCompression = 0& 76 .biPlanes = 1& 77 .biSize = Len(bi.bmiHeader) 78 .biWidth = w 79 .biHeight = h 80 End With 81 Call GetDIBits(hdc, pic.Handle, 0, h, bits(0, 0, 0), bi, 0&) 82 83 '灰度化 84 Dim x As Long 85 Dim y As Long 86 Dim g As Byte 87 For x = 0 To w 88 For y = 0 To h 89 '灰度公式：Gray=R×0.299+G×0.587+B×0.114 90 '貌似有更好的方案：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) 91 '不过，肉眼看不出差别来 (>_<) 92 g = bits(0, x, y) * 0.114 + bits(1, x, y) * 0.587 + bits(2, x, y) * 0.299 93 bits(0, x, y) = g 94 bits(1, x, y) = g 95 bits(2, x, y) = g 96 Next 97 Next 98 99 100 101 Picture1.Picture = Picture1.Image 102 Call SetDIBits(Picture1.hdc, Picture1.Picture.Handle, 0&, h, bits(0, 0, 0), bi, 0&) 103 Picture1.Picture = Picture1.Image 104 105 Dim threshold As Byte 106 threshold = GetThreshold(bits, w, h) 107 108 '二值化，阈值通过[最大类间方差法(Otsu)]取得 109 For x = 0 To w 110 For y = 0 To h 111 If bits(0, x, y) > threshold Then 112 bits(0, x, y) = 255 113 bits(1, x, y) = 255 114 bits(2, x, y) = 255 115 Else 116 bits(0, x, y) = 0 117 bits(1, x, y) = 0 118 bits(2, x, y) = 0 119 End If 120 Next 121 Next 122 123 Picture2.Picture = Picture2.Image 124 Call SetDIBits(Picture2.hdc, Picture2.Picture.Handle, 0&, h, bits(0, 0, 0), bi, 0&) 125 Picture2.Picture = Picture2.Image 126 127 Erase bits 128 Call DeleteDC(hdc) 129 Set pic = Nothing 130 End Sub 131 132 133 Private Function GetThreshold(ByRef Pixels() As Byte, _ 134 ByVal Width As Long, _ 135 ByVal Height As Long) As Byte 136 '最大类间方差法(Otsu) 137 '这个函数是我根据百度文库一个文档里提供的C代码翻译过来的 138 '@http://wenku.baidu.com/link?url=wVl9A7eZiRddxpaCPPLcAIb-VDlyrV__-Zfw6j6o50FEUochgV9G_zRVsMHVDxN2ilOUXiRbSSM-as_ELJpjxnWEvERlABlvVoVK6-FDQpW 139 Dim hist(255) As Long 140 Dim x As Long 141 Dim y As Long 142 Dim i As Long 143 144 For i = 0 To 255: hist(i) = 0: Next 145 For y = 0 To Height 146 For x = 0 To Width 147 hist(Pixels(0, x, y)) = hist(Pixels(0, x, y)) + 1 148 Next 149 Next 150 151 Dim p(255) As Double 152 Dim ut As Double 153 Dim uk As Double 154 Dim sigma As Double 155 Dim mk As Double 156 Dim maxk As Byte 157 Dim maxs As Double 158 Dim total As Long 159 Dim EPSTLON As Double 160 EPSILON = 0.000001 '10 ^ -6 161 162 163 total = Width * Height 164 ut = 0 165 For i = 0 To 255 166 p(i) = hist(i) / total 167 ut = ut + i * hist(i) 168 Next 169 ut = ut / total 170 wk = 0 171 uk = 0 172 maxs = 0 173 For i = 0 To 255 174 uk = uk + i * p(i) 175 wk = wk + p(i) 176 If wk <= EPSTLON Or wk >= (1# - EPSTLON) Then 177 Else 178 sigma = (ut * wk - uk) 179 sigma = (sigma * sigma) / (wk * (1# - wk)) 180 If sigma > maxs Then 181 maxs = sigma 182 maxk = i 183 End If 184 End If 185 Next 186 GetThreshold = maxk 187 End Function
上张图，看看效果：
原图：
