How can I do zonal OCR in VB6?

Question

As you can see down there i made a programme that scans a document and optionally get the page info and material & size infos and date info.

When i use OCR scanning like this:

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

This gets the whole page but i just want those 3 spesific area to be scanned so how can i achive that? Is there any function for that? Which scans only X,Y coordinates?

Answer 1

A vb6 snippet

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

Though the question is tagged as vb6 but answer is from vb.Net 2010. I hope vb.NET could easily be converted to vb6, only matters is just a few more time.

The basic idea is to create an xml file from image and then run a query over the xml file to fetch text of the required block surrounded by (x1,y1) and (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

the 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

UPDATE

The following example reports the page number and the coordinates of the bounding rectangle around the user's image selection in the viewer control. And which can be used later within picturebox.

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

---

Hope this helps.

Answer 2

I used image and pic boxes to crop and resize a picture exactly to HD pixels and size for inclusion in a HD movie. I moved the picture about with slider controls (eg PicSize.Value) The picture box is set to 1900x1080 pixels off screen with Visible=false. The image box size has Stretch set to true with size is not critical and shows a smaller version of the final cropped pic.

I save the picture box as a bmp so it nicely integrates with my AVCHD video in the Adobe editor being the same frame size as the video.

This was the main subroutine:

-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