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