如何在VB6中进行区域OCR？

Question

正如你在那里看到的那样，我制作了一个扫描文档的程序，并可选择获取页面信息和材料。大小信息和日期信息。

当我像这样使用OCR扫描时：

Dim Mdoc As MODI.Document
Dim Mlay As MODI.Layout
Dim fso As Scripting.FileSystemObject
Dim logfile As Object

Public Function ScanMan(ByVal Name As String, ByVal Path As String) As String
    Set Mdoc = New MODI.Document
    'Set Mdoc = CreateObject("MODI.Document")
    Set fso = New Scripting.FileSystemObject

    DoEvents
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''' Create OCRLog File '''''''''''''''''''
    OCRPath = App.Path & "\OCR Results Log\"
    OCRName = Str(DateTime.Date) & " OCRresults"
    If fso.FolderExists(OCRPath) = False Then
        fso.CreateFolder (OCRPath)
    End If
    If fso.FileExists(OCRPath & OCRName & ".txt") = False Then
        fso.CreateTextFile OCRPath & OCRName & ".txt"
    End If
    Set logfile = fso.OpenTextFile(OCRPath & OCRName & ".txt", ForAppending)
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    On Error GoTo OCRErr
    DoEvents
    Mdoc.Create Path & "\" & Name
    Mdoc.Images(0).OCR miLANG_ENGLISH, True, True
    logfile.Write Mdoc.Images(0).Layout.Text

    ScanMan = Mlay.Text

    Mdoc.Close False

    Set Mlay = Nothing
    Set Mdoc = Nothing

    Exit Function

OCRErr:
    logfile.WriteLine "OCR given (" & Err.Number & ") numbered (" & Err.Description & ") error."
    logfile.Close
End Function

这可以获得整个页面，但我只想要扫描那些3个特定区域，那么我怎么能实现呢？那有什么功能吗？哪个只扫描X，Y坐标？

Answer 1

一个vb6代码段

Sub TestTextSelection()

  Dim miTextSel As MODI.IMiSelectableItem
  Dim miSelectRects As MODI.miSelectRects
  Dim miSelectRect As MODI.miSelectRect
  Dim strTextSelInfo As String

  Set miTextSel = MiDocView1.TextSelection
  Set miSelectRects = miTextSel.GetSelectRects
  strTextSelInfo = _
    "Bounding rectangle page & coordinates: " & vbCrLf
  For Each miSelectRect In miSelectRects
    With miSelectRect
      strTextSelInfo = strTextSelInfo & _
        .PageNumber & ", " & .Top & ", " & _
        .Left & ", " & .Bottom & ", " & _
        .Right & vbCrLf
    End With
  Next
  MsgBox strTextSelInfo, vbInformation + vbOKOnly, _
    "Text Selection Info"

  Set miSelectRect = Nothing
  Set miSelectRects = Nothing
  Set miTextSel = Nothing

End Sub

虽然问题被标记为vb6，但答案来自vb.Net 2010。我希望vb.NET可以很容易地转换为vb6，只需要更多时间。

基本思路是从映像创建一个xml文件，然后对xml文件运行查询以获取由（x1,y1）和（x2,y2）包围的所需块的文本。

的 The core class 的

Imports System
Imports System.IO
Imports System.Xml
Imports System.Linq
Imports MODI

Public Class clsCore
    Public Sub New()
        'blah blah blah
    End Sub

    Public Function GetTextFromCoordinates(ByVal iPath$, ByVal x1&, ByVal y1&, ByVal x2&, ByVal y2&) As String
        Try
            Dim xDoc As XElement = Me.ConvertImage2XML(iPath)
            If IsNothing(xDoc) = False Then
                Dim result As New XElement(<text/>)
                Dim query = xDoc...<wd>.Where(Function(c) Val(CStr(c.@left)) >= x1 And Val(CStr(c.@right)) <= x2 And Val(CStr(c.@top)) >= y1 And Val(CStr(c.@bottom)) <= y2)
                For Each ele As XElement In query
                    result.Add(CStr(ele.Value) & " ")
                Next ele
                Return Trim(result.Value)
            Else
                Return ""
            End If
        Catch ex As Exception
            Console.WriteLine(ex.ToString)
            Return ex.ToString
        End Try
    End Function

    Private Function ConvertImage2XML(ByVal iPath$) As XElement
        Try
            If File.Exists(iPath) = True Then
                Dim miDoc As New MODI.Document
                Dim result As New XElement(<image path=<%= iPath %>/>)
                miDoc.Create(iPath)
                For Each miImg As MODI.Image In miDoc.Images
                    Dim page As New XElement(<page id=<%= result...<page>.Count + 1 %>/>)
                    miImg.OCR()
                    For Each miWord As MODI.Word In miImg.Layout.Words
                        Dim wd As New XElement(<wd block=<%= miWord.RegionId.ToString %>><%= miWord.Text %></wd>)
                        For Each miRect As MODI.MiRect In miWord.Rects
                            wd.Add(New XAttribute("left", miRect.Left))
                            wd.Add(New XAttribute("top", miRect.Top))
                            wd.Add(New XAttribute("right", miRect.Right))
                            wd.Add(New XAttribute("bottom", miRect.Bottom))
                        Next miRect
                        page.Add(wd)
                    Next miWord
                    result.Add(page)
                Next miImg
                Return result
            Else
                Return Nothing
            End If
        Catch ex As Exception
            Console.WriteLine(ex.ToString)
            Return Nothing
        End Try
    End Function
End Class

main module

Imports System
Imports System.IO
Imports System.Text.RegularExpressions

Module modMain

    Sub Main()
        Dim iPath$ = "", iPos$ = "150,825,1400,1200"
        Console.WriteLine("Enter path to file:")
        iPath = Console.ReadLine()
        Console.WriteLine("")
        Console.WriteLine("Enter co-ordinates(i.e., x1,y1,x2,y2 or 150,825,1400,1200):")
        iPos = Console.ReadLine()
        Dim tmp As String() = Regex.Split(iPos, "\D+")
        Dim outText$ = New clsCore().GetTextFromCoordinates(iPath, tmp(0), tmp(1), tmp(2), tmp(3))
        Console.WriteLine("")
        Console.WriteLine(String.Format("{0}[({1},{2})-({3},{4})]:{5}{5}{6}", Dir(iPath), tmp(0), tmp(1), tmp(2), tmp(3), vbCrLf, outText))
        Console.ReadLine()
    End Sub

End Module

<强>更新

以下示例报告查看器控件中用户图像选择周围的页码和边界矩形的坐标。以后可以在图片框中使用。

Sub TestImageSelection()

  Dim miImageSel As MODI.IMiSelectableImage
  Dim lngPageNo As Long
  Dim lngLeft As Long, lngTop As Long
  Dim lngRight As Long, lngBottom As Long
  Dim strImageSelInfo As String

  Set miImageSel = MiDocView1.ImageSelection
  miImageSel.GetBoundingRect lngPageNo, _
    lngLeft, lngTop, lngRight, lngBottom
  strImageSelInfo = _
    "Page number: " & lngPageNo & vbCrLf & _
    "Bounding rectangle coordinates: " & vbCrLf & _
    lngLeft & ", " & lngTop & ", " & _
    lngRight & ", " & lngBottom
  MsgBox strImageSelInfo, vbInformation + vbOKOnly, _
    "Image Selection Info"

  Set miImageSel = Nothing

End Sub

---

希望这有帮助。

Answer 2

我使用图像和图片框来精确地裁剪和调整图片大小以适应高清像素和大小以包含在高清电影中。我用滑块控件移动了图片（例如PicSize.Value） 屏幕上的图片框设置为1900x1080像素Visible=false。 图片框大小Stretch设置为true，尺寸并不重要，并显示最终裁剪图片的较小版本。

我将图片框保存为bmp，因此它与Adobe编辑器中的AVCHD视频很好地集成，与视频的帧大小相同。

这是主要的子程序：

-Private Sub Convert()
'Creates a cropped and/or magnified fixed pixel 1900x1080 picture
Dim file_name As String, LeftPos As Long
Picture2.Picture = LoadPicture("")
DoEvents 
' Resize the picture.
LeftPos = 950 + HPos.Value - PicSize.Value / 2 + PicWidth.Value * 20
Picture2.PaintPicture Picture1.Picture, _
    LeftPos, VPos.Value, _
    PicSize.Value - (PicSize.Value * (PicWidth.Value / 50)), _
    PicSize.Value * (Aspect.Value / 100)
Picture2.Picture = Picture2.Image
TopValue.Caption = VPos.Value
HPosValue.Caption = HPos.Value
SizeValue.Caption = PicSize.Value
AspectValue.Caption = Aspect.Value - 75
StretchValue.Caption = PicWidth.Value
Image1.Picture = Picture2.Image 'preview it
End Sub