www.pudn.com > ocr.rar > OcrBas.bas

Attribute VB_Name = "OcrBas" 
'**************************************************************************** 
'人人为我，我为人人 
'枕善居收藏整理 
'发布日期：2008/01/21 
'描    述：OCR手写字体识别软件 
'网    站：http://www.Mndsoft.com/  (VB6源码博客) 
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005) 
'e-mail  ：Mndsoft@163.com 
'e-mail  ：Mndsoft@126.com 
'OICQ    ：88382850 
'          如果您有新的好的代码别忘记给枕善居哦! 
'**************************************************************************** 
 
Public Function OcrBits(Pic1 As PictureBox, Pic2 As PictureBox) As Long '实际进行OCR识别的模块 
Dim i As Long, j As Long 
Dim hOldMap As Long 
Dim PicBits() As Byte 
Dim iBitmap As Long, iDC As Long 
Dim bi24BitInfo As BITMAPINFO 
Dim Pic2Bits() As Byte 
Dim i2Bitmap As Long, i2DC As Long 
Dim bi24Bit2Info As BITMAPINFO 
Dim AllBits As Long, SameBits As Long 
With bi24BitInfo.bmiHeader 
    .biBitCount = 32 
    .biCompression = BI_RGB 
    .biPlanes = 1 
    .biSize = Len(bi24BitInfo.bmiHeader) 
    .biWidth = Pic1.ScaleWidth 
    .biHeight = Pic1.ScaleHeight 
    .biSizeImage = .biWidth * 4 * .biHeight 
End With 
iDC = CreateCompatibleDC(0) 
iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&) 
If iBitmap Then 
  hOldMap = SelectObject(iDC, iBitmap) 
Else 
  DeleteObject iDC 
  Exit Function 
End If 
BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, Pic1.hdc, 0, 0, vbSrcCopy 
ReDim PicBits(1 To 4, 1 To bi24BitInfo.bmiHeader.biWidth, 1 To bi24BitInfo.bmiHeader.biHeight) As Byte 
GetBitmapBits iBitmap, bi24BitInfo.bmiHeader.biSizeImage, PicBits(1, 1, 1) 
 
With bi24Bit2Info.bmiHeader 
    .biBitCount = 32 
    .biCompression = BI_RGB 
    .biPlanes = 1 
    .biSize = Len(bi24BitInfo.bmiHeader) 
    .biWidth = Pic2.ScaleWidth 
    .biHeight = Pic2.ScaleHeight 
    .biSizeImage = .biWidth * 4 * .biHeight 
End With 
i2DC = CreateCompatibleDC(0) 
i2Bitmap = CreateDIBSection(i2DC, bi24Bit2Info, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&) 
If i2Bitmap Then 
  hOldMap = SelectObject(i2DC, i2Bitmap) 
Else 
  DeleteObject i2DC 
  Exit Function 
End If 
BitBlt i2DC, 0, 0, bi24Bit2Info.bmiHeader.biWidth, bi24Bit2Info.bmiHeader.biHeight, Pic2.hdc, 0, 0, vbSrcCopy 
ReDim Pic2Bits(1 To 4, 1 To bi24Bit2Info.bmiHeader.biWidth, 1 To bi24Bit2Info.bmiHeader.biHeight) As Byte 
GetBitmapBits i2Bitmap, bi24Bit2Info.bmiHeader.biSizeImage, Pic2Bits(1, 1, 1) 
AreaHeight = LargeFix(Pic2.ScaleHeight / 4) 
AreaWidth = LargeFix(Pic2.ScaleWidth / 4) 
For i = 1 To bi24BitInfo.bmiHeader.biWidth 
  For j = 1 To bi24BitInfo.bmiHeader.biHeight 
    If Pic2Bits(1, i, j) = PicBits(1, i, j) Then SameBits = SameBits + 1 
  Next j 
Next i 
AllBits = bi24BitInfo.bmiHeader.biSizeImage 
OcrBits = SameBits / AllBits * 10000 
If hOldMap Then DeleteObject SelectObject(iDC, hOldMap) 
DeleteObject iDC 
If hOldMap Then DeleteObject SelectObject(i2DC, hOldMap) 
DeleteObject i2DC 
End Function 
 
Public Function BlackBits(Pic As PictureBox) '将图象简单二值化，主要是因为实时生成的文字不是纯黑色 
Dim i As Long 
Dim hOldMap As Long 
Dim PicBits() As Byte 
Dim iBitmap As Long, iDC As Long 
Dim bi24BitInfo As BITMAPINFO 
With bi24BitInfo.bmiHeader 
    .biBitCount = 32 
    .biCompression = BI_RGB 
    .biPlanes = 1 
    .biSize = Len(bi24BitInfo.bmiHeader) 
    .biWidth = Pic.ScaleWidth 
    .biHeight = Pic.ScaleHeight 
    .biSizeImage = .biWidth * 4 * .biHeight 
End With 
iDC = CreateCompatibleDC(0) 
iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&) 
If iBitmap Then 
  hOldMap = SelectObject(iDC, iBitmap) 
Else 
  DeleteObject iDC 
  Exit Function 
End If 
BitBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, Pic.hdc, 0, 0, vbSrcCopy 
ReDim PicBits(0 To bi24BitInfo.bmiHeader.biSizeImage) As Byte 
GetBitmapBits iBitmap, bi24BitInfo.bmiHeader.biSizeImage, PicBits(0) 
For i = 0 To bi24BitInfo.bmiHeader.biSizeImage 
  If PicBits(i) <> 255 Then PicBits(i) = 0 
Next i 
SetBitmapBits iBitmap, bi24BitInfo.bmiHeader.biSizeImage, PicBits(0) 
BitBlt Pic.hdc, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, iDC, 0, 0, vbSrcCopy 
Pic.Refresh 
If hOldMap Then DeleteObject SelectObject(iDC, hOldMap) 
DeleteObject iDC 
BlackBits = True 
End Function 
 
Function CutLetters(Pic As PictureBox) As RECT '切掉文字旁边不需要的部分，以提高识别率 
Dim i As Long, j As Long 
CutLetters.Left = -1 
CutLetters.Right = -1 
CutLetters.Top = -1 
CutLetters.Bottom = -1 
For i = 0 To Pic.ScaleWidth 
  For j = 0 To Pic.ScaleHeight 
    If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Left = i 
  Next j 
  If CutLetters.Left <> -1 Then Exit For 
Next i 
For i = Pic.ScaleWidth To 0 Step -1 
  For j = Pic.ScaleHeight To 0 Step -1 
    If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Right = i + 1 
  Next j 
  If CutLetters.Right <> -1 Then Exit For 
Next i 
For j = 0 To Pic.ScaleHeight 
  For i = 0 To Pic.ScaleWidth 
    If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Top = j 
  Next i 
  If CutLetters.Top <> -1 Then Exit For 
Next j 
For j = Pic.ScaleHeight To 0 Step -1 
  For i = Pic.ScaleWidth To 0 Step -1 
    If GetPixel(Pic.hdc, i, j) = &H0& Then CutLetters.Bottom = j + 1 
  Next i 
  If CutLetters.Bottom <> -1 Then Exit For 
Next j 
End Function