VB6 mysql 图像_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 AsAny, _12 lpBI AsBitMapInfo, _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 AsAny, _19 lpBI AsBitMapInfo, _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 PrivateType BitMapInfoHeader30 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 EndType42

43 PrivateType RGBQuad44 rgbBlue As Byte

45 rgbGreen As Byte

46 rgbRed As Byte

47 ''rgbReserved As Byte

48 EndType49

50 PrivateType BitMapInfo51 bmiHeader AsBitMapInfoHeader52 bmiColors AsRGBQuad53 EndType54

55 Private SubCommand1_Click()56 Dim pic AsStdPicture57 Set pic = LoadPicture("D:\My Documents\Downloads\119562132_21n.jpg")58

59 Dim w As Long

60 Dim h As Long

61 Withpic62 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 CallSelectObject(hdc, pic.Handle)69

70 Dim bits() As Byte

71 ReDim bits(3, w, h) As Byte

72 Dim bi AsBitMapInfo73 Withbi.bmiHeader74 .biBitCount = 32&

75 .biCompression = 0&

76 .biPlanes = 1&

77 .biSize = Len(bi.bmiHeader)78 .biWidth =w79 .biHeight =h80 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 Tow88 For y = 0 Toh89 '灰度公式：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) =g94 bits(1, x, y) =g95 bits(2, x, y) =g96 Next

97 Next

98

99

100

101 Picture1.Picture =Picture1.Image102 Call SetDIBits(Picture1.hdc, Picture1.Picture.Handle, 0&, h, bits(0, 0, 0), bi, 0&)103 Picture1.Picture =Picture1.Image104

105 Dim threshold As Byte

106 threshold =GetThreshold(bits, w, h)107

108 '二值化，阈值通过[最大类间方差法(Otsu)]取得

109 For x = 0 Tow110 For y = 0 Toh111 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.Image124 Call SetDIBits(Picture2.hdc, Picture2.Picture.Handle, 0&, h, bits(0, 0, 0), bi, 0&)125 Picture2.Picture =Picture2.Image126

127 Erasebits128 CallDeleteDC(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 ToHeight146 For x = 0 ToWidth147 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 *Height164 ut = 0

165 For i = 0 To 255

166 p(i) = hist(i) /total167 ut = ut + i *hist(i)168 Next

169 ut = ut /total170 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 =sigma182 maxk =i183 End If

184 End If

185 Next

186 GetThreshold =maxk187 End Function