tagCANDY CGI VBレスキュー(花ちゃん) の Visual Basic 2010 用 掲示板(VB.NET 掲示板) [ツリー表示へ]   [Home]
一括表示(VB.NET VB2005)
タイトルMicrosoft Office Document Imagingを使ってみました
記事No7208
投稿日: 2008/03/17(Mon) 17:07
投稿者ひでと
質問ではないです。Microsoft Office Document Imagingを使って、
イメージファイルファイルから数字を取り出す処理を作ってみました。
一応載せておきますが、素人ですのでご指摘いただければと思います。
二つに分けておきます

    Structure st_scWord
        Dim text As String
        Dim left As Integer
        Dim right As Integer
        Dim top As Integer
        Dim bottom As Integer
    End Structure
    Dim scWords As New List(Of st_scWord)
    Dim ScNums As New List(Of st_scWord)
    Dim ScSchrs As New List(Of st_scWord)
    Dim NScNums As New List(Of st_scWord)
    Sub GetOCR(ByVal FileName As String)
        Dim myDoc As MODI.Document
        Dim myImage As MODI.Image
        Dim myLayout As MODI.ILayout
        Dim myWords As MODI.IWords
        Dim myWord As MODI.IWord
        Dim myRects As MODI.MiRects
        Dim myRect As MODI.MiRect

        Dim i As Integer
        Dim scWord As st_scWord
        myDoc = New MODI.Document
        myDoc.Create(FileName)

        myDoc.OCR()
        myImage = myDoc.Images(0)
        myLayout = myImage.Layout
        myWords = myLayout.Words
        For i = 0 To myWords.Count - 1
            myWord = myWords(i)
            scWord.text = myWord.Text
            myRects = myWord.Rects
            myRect = myRects(0)
            scWord.left = myRect.Left
            scWord.right = myRect.Right
            scWord.top = myRect.Top
            scWord.bottom = myRect.Bottom
            scWords.Add(scWord)
        Next
    End Sub
    Private Function minScWLeft() As Integer
        Dim i As Integer
        Dim dum As Integer
        dum = scWords(0).left
        For i = 0 To scWords.Count - 1
            If dum > scWords(i).left Then dum = scWords(i).left
        Next
        Return dum
    End Function
    Private Function maxScWRight() As Integer
        Dim i As Integer
        Dim dum As Integer
        dum = scWords(0).right
        For i = 0 To scWords.Count - 1
            If dum < scWords(i).right Then dum = scWords(i).right
        Next
        Return dum
    End Function
    Private Function minScWTop() As Integer
        Dim i As Integer
        Dim dum As Integer
        dum = scWords(0).top
        For i = 0 To scWords.Count - 1
            If dum > scWords(i).top Then dum = scWords(i).top
        Next
        Return dum
    End Function
    Private Function maxScWBottom() As Integer
        Dim i As Integer
        Dim dum As Integer
        dum = scWords(0).bottom
        For i = 0 To scWords.Count - 1
            If dum < scWords(i).bottom Then dum = scWords(i).bottom
        Next
        Return dum
    End Function
    Private Function ScwWidth() As Integer
        Dim dum As Integer
        dum = maxScWRight() - minScWLeft()
        Return dum
    End Function
    Private Function ScwHeight() As Integer
        Dim dum As Integer
        dum = maxScWBottom() - minScWTop()
        Return dum
    End Function
    Private Function ScwScale(ByVal Obj As PictureBox) As Single
        Dim dum As Single
        dum = Obj.Width / ScwWidth()
        Return dum
    End Function

[ツリー表示へ]
タイトルMicrosoft Office Document Imagingを使ってみました2
記事No7209
投稿日: 2008/03/17(Mon) 17:08
投稿者ひでと
    Private Function IsNumeral(ByVal Str As String) As Boolean
        Dim i As Integer
        Dim dum As Boolean
        If Mid(Str, 1, 1) >= "0" And Mid(Str, 1, 1) <= "9" Then
            dum = True
        Else
            dum = False : Return False
        End If
        For i = 2 To Len(Str)
            If dum = True Then
                Select Case Mid(Str, i, 1)
                    Case "-", ".", "," : dum = True
                    Case Else
                        If Mid(Str, i, 1) >= "0" And Mid(Str, i, 1) <= "9" Then
                            dum = True
                        Else
                            dum = False : Exit For
                        End If
                End Select
            End If
        Next
        Return dum
    End Function
    Private Function IsNSChangeing(ByVal Str As String) As Boolean
        Dim i As Integer
        Dim isNum As Boolean
        If Mid(Str, 1, 1) >= "0" And Mid(Str, 1, 1) <= "9" Then
            isNum = True
        End If
        For i = 2 To Len(Str)
            If isNum Then
                Select Case Mid(Str, i, 1)
                    Case "-", ".", ","
                    Case Else
                        If Mid(Str, i, 1) >= "0" And Mid(Str, i, 1) <= "9" Then
                        Else
                            isNum = False : Return True
                        End If
                End Select
            Else
                Select Case Mid(Str, i, 1)
                    Case "-", ".", "," : isNum = False
                    Case Else
                        If Mid(Str, i, 1) >= "0" And Mid(Str, i, 1) <= "9" Then
                            isNum = True : Return True
                        Else
                            isNum = False
                        End If
                End Select
            End If
        Next
        Return False
    End Function
    Private Sub ScwDevide(ByVal index As Integer, ByVal nfont As Font, ByVal Obj As PictureBox)
        Dim G As Graphics = Obj.CreateGraphics
        Dim preWidth As Integer
        Dim newWidth As Integer
        Dim fontLengScale As Single
        Dim oldText As String
        Dim newText As String
        Dim i As Integer
        Dim chk As Boolean
        Dim ScNum As New st_scWord
        Dim ScSchr As New st_scWord
        oldText = scWords(index).text
        preWidth = G.MeasureString(oldText, nfont).Width
        fontLengScale = preWidth / (scWords(index).right - scWords(index).left)
        newText = Mid(oldText, 1, 1)
        With ScNum
            .text = scWords(index).text
            .top = scWords(index).top
            .bottom = scWords(index).bottom
            .left = scWords(index).left
            .right = scWords(index).right
        End With
        With ScSchr
            .text = scWords(index).text
            .top = scWords(index).top
            .bottom = scWords(index).bottom
            .left = scWords(index).left
            .right = scWords(index).right
        End With

        If IsNumeral(newText) Then
            chk = True
        Else
            chk = False
        End If
        i = 1
        Do While i <= Len(oldText)
            newText = Mid(oldText, 1, i)
            If chk = True Then
                If IsNSChangeing(newText) Then
                    newWidth = G.MeasureString(newText, nfont).Width
                    newText = Mid(newText, 1, Len(newText) - 1)
                    With ScNum
                        .text = newText
                        .right = ScNum.left + newWidth * fontLengScale
                    End With
                    ScSchr.left = ScNum.right
                    ScNums.Add(ScNum)
                    chk = False
                    oldText = Mid(oldText, Len(newText) + 1)
                    i = 0
                End If
            Else
                If IsNSChangeing(newText) Then
                    newWidth = G.MeasureString(newText, nfont).Width
                    newText = Mid(newText, 1, Len(newText) - 1)
                    With ScSchr
                        .text = newText
                        .right = ScSchr.left + newWidth * fontLengScale
                    End With
                    ScNum.left = ScSchr.right
                    ScSchrs.Add(ScNum)
                    chk = True
                    oldText = Mid(oldText, Len(newText) + 1)
                    i = 0
                End If
            End If
            i = i + 1
        Loop
        If IsNumeral(oldText) Then
            ScNum.text = oldText
            ScNums.Add(ScNum)
        Else
            ScSchr.text = oldText
            ScSchrs.Add(ScSchr)
        End If


    End Sub
    Private Sub ScwPicDeVide(ByVal Obj As PictureBox)
        Dim G As Graphics = Obj.CreateGraphics
        Dim nfont As Font
        Dim i As Integer
        Dim preHeight As Integer
        Dim FontScale As Single

        For i = 0 To scWords.Count - 1
            nfont = New Font("MS 明朝", 10)
            preHeight = G.MeasureString(scWords(i).text, nfont).Height
            FontScale = preHeight / (scWords(i).bottom - scWords(i).top)
            nfont = New Font("MS 明朝", 10 * FontScale)
            ScwDevide(i, nfont, Obj)
        Next
    End Sub

    Private Sub Button1_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim Ret As DialogResult
        Dim FileName As String
        Me.OpenFileDialog1.Filter = "すべてのイメージドキュメント(*.mdi;*.tif;*.tiff)|*.mdi;*.tif;*.tiff)"
        Ret = Me.OpenFileDialog1.ShowDialog
        If Ret = Windows.Forms.DialogResult.OK Then
            FileName = Me.OpenFileDialog1.FileName.ToString
        Else
            Exit Sub
        End If
        GetOCR(FileName)
        ScwPicDeVide(Me.PictureBox1)
        PictureBox1.Refresh()
    End Sub

    Private Sub PictureBox1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles PictureBox1.Paint
        Dim G As Graphics = e.Graphics
        Dim nfont As Font
        Dim i As Integer
        Dim preHeight As Integer
        Dim FontScale As Single
        Dim Scale As Single
        Dim minx, miny As Integer
        Dim x, y As Integer

        For i = 0 To ScNums.Count - 1
            nfont = New Font("MS 明朝", 10)
            preHeight = G.MeasureString(ScNums(i).text, nfont).Height
            FontScale = preHeight / (ScNums(i).bottom - ScNums(i).top)
            nfont = New Font("MS 明朝", 10 * FontScale)
            Scale = ScwScale(Me.PictureBox1)
            minx = minScWLeft()
            miny = minScWTop()
            x = (ScNums(i).left - minx) * Scale
            y = (ScNums(i).top - miny) * Scale
            G.DrawString(ScNums(i).text, nfont, Brushes.Black, x, y)
        Next
    End Sub

    Private Sub PictureBox1_Resize(ByVal sender As Object, ByVal e As System.EventArgs) Handles PictureBox1.Resize
        Try
            Me.PictureBox1.Height = ScwHeight() * ScwScale(Me.PictureBox1)
        Catch ex As Exception
        End Try
        PictureBox1.Refresh()
    End Sub
    Private Sub YSort(ByRef Obj As List(Of st_scWord))
        If Obj.Count = 0 Then Exit Sub
        Dim i, j As Integer
        Dim dum As New st_scWord
        Dim dum2 As New List(Of st_scWord)
        dum2 = Obj
        For i = 0 To dum2.Count - 2
            For j = dum2.Count - 1 To i + 1 Step -1
                If dum2(j).top < dum2(j - 1).top Then
                    dum = dum2(j)
                    dum2(j) = dum2(j - 1)
                    dum2(j - 1) = dum
                End If
            Next
        Next
        Obj = dum2
    End Sub
    Private Sub XSort(ByRef Obj As List(Of st_scWord))
        If Obj.Count = 0 Then Exit Sub
        Dim i, j As Integer
        Dim dum As New st_scWord
        Dim dum2 As New List(Of st_scWord)
        dum2 = Obj
        For i = 0 To dum2.Count - 2
            For j = dum2.Count - 1 To i + 1 Step -1
                If dum2(j).left < dum2(j - 1).left Then
                    dum = dum2(j)
                    dum2(j) = dum2(j - 1)
                    dum2(j - 1) = dum
                End If
            Next
        Next
        Obj = dum2
    End Sub
    Private Function isSameRow(ByVal Obj As List(Of st_scWord), ByVal Targ As st_scWord) As Boolean
        Dim i As Integer
        Dim topMin, bottomMax As Integer
        topMin = Obj(0).top
        bottomMax = Obj(0).bottom
        For i = 0 To Obj.Count - 1
            If topMin > Obj(i).top Then topMin = Obj(i).top
            If bottomMax < Obj(i).bottom Then bottomMax = Obj(i).bottom
        Next
        If topMin >= Targ.top And topMin <= Targ.bottom Then Return True
        If bottomMax >= Targ.top And bottomMax <= Targ.bottom Then Return True
        If topMin <= Targ.top And bottomMax >= Targ.top Then Return True
        Return False
    End Function
    Private Sub Maketext(ByVal TextFile As IO.StreamWriter)
        Dim i As Integer
        Dim Row As New List(Of st_scWord)
        Dim NewStr As String = ""

        Row.Add(NScNums(0))
        NScNums.Remove(NScNums(0))
        i = 0
        Do Until i >= NScNums.Count - 1
            If isSameRow(Row, NScNums(i)) Then
                Row.Add(NScNums(i))
                NScNums.Remove(NScNums(i))
                If NScNums.Count = 1 Then Exit Do
                i = i - 1
            End If
            i = i + 1
        Loop
        XSort(Row)
        For i = 0 To Row.Count - 1
            If i = Row.Count - 1 Then
                NewStr = NewStr & Row(i).text
            Else
                NewStr = NewStr & Row(i).text & Me.TextBox1.Text
            End If
        Next
        TextFile.WriteLine(NewStr)
        If NScNums.Count = 1 Then Exit Sub
        '再起
        Maketext(TextFile)
    End Sub

    Private Sub Button2_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button2.Click
        Dim TextFile As IO.StreamWriter
        Dim i As Integer
        Dim ret As DialogResult
        ret = Me.SaveFileDialog1.ShowDialog
        If ret = Windows.Forms.DialogResult.OK Then
            TextFile = New IO.StreamWriter(Me.SaveFileDialog1.FileName)
        Else
            Exit Sub
        End If
        YSort(ScNums)
        For i = 0 To ScNums.Count - 1
            NScNums.Add(ScNums(i))
        Next
        Maketext(TextFile)
        TextFile.Close()
    End Sub

[ツリー表示へ]