おおぞらのとんび

↓が設定シートのコードです。コピペしてください。


'*****************************************************************************
'* まず初めにライブラリの参照設定をすること
'* メニュー > ツール > 参照設定
'* □Microsoft Office Document Imaging 11.0 Type Library　←にチェック
'*****************************************************************************


'*****************************************************************************
'* クリップボード関連
'* ネット上のサンプル拝借
'*****************************************************************************
Option Explicit

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GetClipBoardData Lib "User32" Alias "GetClipboardData" (ByVal wFormat As Long) As Long
Private 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 Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPictureDisp) As Long


Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private 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 = ObjPic
End 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 Select

On 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 ' 単語区切りごとに文字出力

'レイアウト情報を取得できる。これを元に１行（文字列）や、横位置などを判定し出力できるが、とりあえず参考まで。
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 = Nothing



Exit Function
ErrOCR1:
'構文1のエラーに対する処理
fncWrokOCR = "OCRエラー"
docDocu.Close
Set docDocu = Nothing
End Function



--文字制限のため次へ続きます。-------