Excel VBA 画像のトリミングとOCR 2
↓が設定シートのコードです。コピペしてください。'*****************************************************************************'* まず初めにライブラリの参照設定をすること'* メニュー > ツール > 参照設定'* □Microsoft Office Document Imaging 11.0 Type Library ←にチェック'*****************************************************************************'*****************************************************************************'* クリップボード関連'* ネット上のサンプル拝借'*****************************************************************************Option ExplicitPrivate Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As ByteEnd TypePrivate Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As LongEnd TypePrivate Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) As LongPrivate Declare Function CloseClipboard Lib "User32" () As LongPrivate Declare Function GetClipBoardData Lib "User32" Alias "GetClipboardData" (ByVal wFormat As Long) As LongPrivate Declare Function CopyImage Lib "User32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPrivate Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPictureDisp) As LongPrivate Const CF_BITMAP = 2Private Const PICTYPE_BITMAP = 1Private Const IMAGE_BITMAP = 0Private Const LR_COPYRETURNORG = &H4'図の中の文字が少ない場合の精度UP処理用Private Const CST_STR_F = "F" '最後に付け足す文字Private Const CST_INT_F = 5 'CST_STR_Fの個数'Private Function GetBitMap() As IPictureDisp Dim iid As GUID Dim Pic As PicBmp Dim ObjPic As IPictureDisp Dim hBitmap As Long Dim CopyBitmap As Long With iid .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With If OpenClipboard(0&) = 0 Then MsgBox "クリップボードを開けませんでした" Exit Function End If hBitmap = GetClipBoardData(CF_BITMAP) If hBitmap = 0 Then CloseClipboard Exit Function End If CopyBitmap = CopyImage(hBitmap, _ IMAGE_BITMAP, 0, 0, _ LR_COPYRETURNORG) CloseClipboard With Pic .Size = Len(Pic) .Type = PICTYPE_BITMAP .hBmp = CopyBitmap End With OleCreatePictureIndirect Pic, iid, 1, ObjPic Set GetBitMap = ObjPicEnd Function'*****************************************************************************'* ここがメイン処理'*'*****************************************************************************Private Sub CommandButton1_Click() Dim i As Integer Dim strFilename As String Dim strFilePass As String Dim strTrimPass As String Dim sglTop As Single Dim sglBtm As Single Dim sglLft As Single Dim sglRgt As Single Dim intMaxCell As Integer Dim strOType As String Dim strSName As String Dim strCAddr As String 'OCRするファイル取得Functionへ strFilePass = fncGetFilePass() If strFilePass = "" Then Exit Sub intMaxCell = Range("B5").End(xlDown).Row For i = 6 To intMaxCell '設定読み込み strOType = Cells(i, 3).Value sglTop = Cells(i, 4).Value sglBtm = Cells(i, 5).Value sglLft = Cells(i, 6).Value sglRgt = Cells(i, 7).Value strSName = Cells(i, 8).Value strCAddr = Cells(i, 9).Value 'トリミングするFunctionへ strTrimPass = fncPicTrimming(strFilePass, sglTop, sglBtm, sglLft, sglRgt) If strFilePass = "" Then Exit Sub 'OCR実行するFunctionへ On Error Resume Next ThisWorkbook.Sheets(strSName).Range(strCAddr).Value = fncWrokOCR(strTrimPass, strOType) Next ''ファイル名の切り出し 'strFilename = Dir(strFilePass) ''パス名の切り出し 'strFilePass = Left(strFilePass, Len(strFilePass) - Len(strFilename) - 1)End Sub'*****************************************************************************'* OCR実行'* ネットからサンプルを拝借し加工'*****************************************************************************Private Function fncWrokOCR(strPass As String, strType) As String Dim i As Integer Dim strWrk As String Dim docDocu As MODI.Document Dim imgImag As MODI.Image Dim lytLayo As MODI.Layout Dim wrdWord As MODI.Word fncWrokOCR = "" Set docDocu = New MODI.Document '画像を読ませる docDocu.Create (strPass)'OCRでエラーが出る場合の対策(日本語の場合、解読図の中に日本語が無いとエラーなることがあるため)On Error GoTo ErrOCR1 'MODI.MiLANGUAGESのタイプ ここで少々時間がかかる。 Select Case strType Case "英数字" '英数字:miLANG_ENGLISH docDocu.OCR miLANG_ENGLISH, False, False Case "日本語" '日本語:miLANG_JAPANESE(17) docDocu.OCR miLANG_JAPANESE, False, False Case Else '以外 docDocu.OCR miLANG_JAPANESE, False, False End SelectOn Error GoTo 0 Set imgImag = docDocu.Images(0) '1ページ目? 複数ページのドキュメント対応? Set lytLayo = imgImag.Layout '全ての認識文字を出力 Cells(2, 5).Value = Left(lytLayo.Text, 30) strWrk = "" 'セルへ個々の文字を出力 For i = 0 To lytLayo.Words.Count - 1 Set wrdWord = lytLayo.Words.Item(i) ' 実用では Rects → Rect.* で場所を確認すべき strWrk = strWrk + wrdWord.Text ' 単語区切りごとに文字出力 'レイアウト情報を取得できる。これを元に1行(文字列)や、横位置などを判定し出力できるが、とりあえず参考まで。 Cells(i + 5, 11).Value = wrdWord.Text Cells(i + 5, 12).Value = wrdWord.Rects.Item(0).Top Cells(i + 5, 13).Value = wrdWord.Rects.Item(0).Bottom Cells(i + 5, 14).Value = wrdWord.Rects.Item(0).Left Cells(i + 5, 15).Value = wrdWord.Rects.Item(0).Right Next '図の中の文字が少ない場合の精度UP処理 For i = 1 To CST_INT_F If Right(strWrk, 1) = CST_STR_F Then strWrk = Left(strWrk, Len(strWrk) - 1) End If Next fncWrokOCR = strWrk Set wrdWord = Nothing Set lytLayo = Nothing Set imgImag = Nothing docDocu.Close Set docDocu = Nothing'参考にしたサンプル'Dim oDocument ' As New MODI.Document'Dim oImage ' As MODI.Image'Dim oLayout ' As MODI.Layout'Dim oWord ' As MODI.Word'Dim i ' As Integer'' Set oDocument = CreateObject("MODI.Document")' oDocument.Create "C:\work\hogehoge.jpg" ' GIFや Jpeg画像を読ませる' oDocument.OCR 17 '17:miLANG_JAPANESE ' ここで少々時間がかかる。' Set oImage = oDocument.Images(0) ' 複数ページのドキュメント対応?1ページ目' Set oLayout = oImage.Layout' WScript.Echo oLayout.Text ' 全ての認識文字を出力' For i = 0 To oLayout.Words.Count - 1' Set oWord = oLayout.Words.Item(i) ' 実用では Rects → Rect.* で場所を確認すべき' WScript.Echo "[" & oWord.Text & "]" ' 単語区切りごとに文字出力' Next' Set oWord = Nothing' Set oLayout = Nothing' Set oImage = Nothing' oDocument.Close' Set oDocument = NothingExit FunctionErrOCR1: '構文1のエラーに対する処理 fncWrokOCR = "OCRエラー" docDocu.Close Set docDocu = NothingEnd Function--文字制限のため次へ続きます。-------