ocrbas.bas

详细说明：手写识别源码

Attribute VB_Name = "OcrBas"
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2008/01/21
'描    述：OCR手写字体识别软件
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'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