概要
PDFページ上のテキストを検索し、以下の位置情報を返します。
- ページ番号
- 座標（四隅の各位置）
これが有れば、テキストへのハイライト表示、取り消し線、下線、リンク、注釈等の追加が可能になります。
 |
当関数はAcrobat OLE経由でAcrobat JavaScriptを実行し、PDF上のテキストの座標を取得します。
テキストの座標はQuads値
座標はAcrobat JavaScriptのQuadsプロパティの形式で返します。８つの値を一組でテキストの四方座標を示します。
各値はカンマ区切りです。例えば、↓ こんな感じです。
[ 1x , 1y , 2x , 2y , 3x , 3y , 4x , 4y ] = [ 91.58000183105469 , 621.9847412109375 , 119.71980285644531 , 621.9847412109375 , 91.58000183105469 , 614.0368041992188 , 119.71980285644531 , 614.0368041992188 ]
小数点以下は不要にも思えますが、当関数では何も加工せずに返しています。
機能
- 指定したPDFページのテキストを検索します。
- 検索テキストは半角文字、全角文字（日本語）、混在の文字、複数の単語が含まれた文字列（途中に半角の空白）でも構いません。
- 一致したテキストの座標（Quadsプロパティの値）を返します。座標はページ左下を基点（ 0, 0 ）とします。
- 検索テキストが複数行（列）にまたがる場合は複数の座標を返します。
- 検索ページの範囲を簡易ですが指定できます。
制限
- ページにまたがるテキストは検索できません。
- 半角英字は大文字小文字を区別します。
理由：区別無しは処理が複雑になる為
対処：区別無しにしたい場合は、大文字有り、大文字無しを検索文字に追加して下さい。 - テキスト中に改行コード、タブ等の制御コードは使えません。使うと検索できません。
注意事項
- PDF上に表示されているテキストの座標を正確に返せない場合が有ります。原因はAcrobat側がテキストと一対一の座標を返さないからです。以下の場合は注意です。
- 表紙、裏表紙
- 目次、索引、表、一覧等のリスト形式の書式
- 数式や図中のテキスト ※ほぼ100％に近い
- 上記問題はAcrobat側、PDF側の問題で関数側ではどうしても回避できません。該当ページを個別に手作業で修正するなどを検討してください。
この問題に関しては時間が出来たら再度検討するつもりです。
形式
Public Function GetTextsGetRects( _
ByVal sPdfFilePath As String , _
ByVal iPageStartIn As Long , _
ByVal iPageEndIn As Long , _
ByRef gSerch() As typeSerchTexts , _
ByRef gRects() As typeTextRect , _
ByRef lOutCnt As Long ) As Boolean
引数
設定する必要があるのは第一、第二、第三、と第四のsSerchTextです。他は関数側で返します。
- 第一引数（sPdfFilePath）：検索するPDFのフルパス
- 第二引数（iPageStartIn）：検索の開始ページ
先頭ページは１です。
-1 を入れると先頭ページから検索します。 - 第三引数（iPageEndIn）： 検索の終了ページ
-1 を入れると最終ページまで検索します。 - 第四引数（gSerch(n) As typeSerchTexts）：
- sSerchText As String：検索する文字列を指定
注意：スペースが入った半角文字列の扱い - iCnt As Long：sSerchTextで検索で一致した件数
- sSerchText As String：検索する文字列を指定
- 第五引数（gRects(x) As typeTextRect）：検索した結果
- iPageNo As Long ：ページ番号
- iSearchNo As Long：sSerchTextの配列番号のn
- sQuads As String：Quadsプロパティの座標値
全てカンマ区切りです。８個単位で一組。
- 第六引数（iOutCnt)： gRects(x) の x 値
検索した合計数。
typeSerchTexts と typeTextRect はユーザー定義形のType変数です。使い方はサンプルを御覧ください。
戻り値
- True : 正常
- False : エラー。第一引数のファイルがPDFで無い等。
動作検証した環境
- Windows 10 64bit Pro
- Adobe Acrobat XI Pro （バージョン 11.0.23）
- MS Office - Excel 2007 - VBA
関数のソース - VBA
以下のダウンロードファイルには当関数を使う上で必要な他の関数やサブルーチン、当関数をつかったサンプルロジック（ハイライト表示、多角形の注釈の作成）が入っています。
ダウンロード：sample-GetTextsGetRects.xls
参照設定が２つ必要です。
当関数を使ったサンプルも２つ入れています。当ページの後半に紹介しています。
001 Option Explicit
002
003 'Debug Mode True：オン False：オフ
004 Private Const DG_MD As Boolean = False
005 Private sDebug As String
006
007 'Acrobat JavaScriptからQuads座標
008 Public Enum JZ
009 iTop = 1
010 iTop2 = 3
011 iBottom = 5
012 iBottom2 = 7
013 iLeft = 0
014 iLeft2 = 4
015 iRight = 2
016 iRight2 = 6
017 End Enum
018 '0[Left]1[Top]2[Right]3[Top]
019 '4[Left]5[Bottom]6[Right]7[Bottom]
020
021 'Acrobat JavaScriptからQuads座標
022 Public Enum JZ2
023 i1x = 0
024 i1y = 1
025 i2x = 2
026 i2y = 3
027 i3x = 4
028 i3y = 5
029 i4x = 6
030 i4y = 7
031 End Enum
032
033 'Private Enum Zahyo '四方座標
034 ' iTop = 0
035 ' iBottom = 1
036 ' iLeft = 2
037 ' iRight = 3
038 'End Enum
039
040 Public Type type_TextRect
041 iPageNo As Long 'ページ番号
042 iSearchNo As Long 'sSerchTextの配列番号：n
043 sQuads As String 'Quads値
044 ' sText As String 'Debug用
045 End Type
046
047 Private Type type_Js1Rect
048 sText As String 'テキスト
049 sQuads As String 'Quads値
050 iQuadsCnt As Long 'Quads数
051 bSpace As Boolean 'Ture：空白有 False：無
052 bCRLF As Boolean 'True：CRLFコード有 False：無
053 bLF As Boolean 'True：LFコード有 False：無
054 bCR As Boolean 'True：CRコード有 False：無
055 End Type
056
057 Private Type type_Js2Rect
058 iIndex As Long 'sJ1_Rtへ連携する添字
059 sText As String 'テキスト ※1文字
060 iMargeNo As Long 'マージできる番号
061 sQuads As String 'Quads値(8座標とは限らない)
062 bSpace As Boolean 'True：最後に空白１つ有り
063 bCRLF As Boolean 'True：最後にCRLFコード有り
064 bLF As Boolean 'True：最後にLFコード有り
065 bCR As Boolean 'True：最後にCRコード有り
066
067 iQuadsType As Long '(未使用)Quads値のタイプ
068 iQuadsCalc As Long '(未使用)0:単独 1:計算値
069 iQuadsIndex As Long '(未使用)Quads値の計算上の組番号
070 '0：単独
071 '1～：計算値
072 End Type
073
074 ' マージ可能の判断番号
075 Private giMergeNo As Long
076
077 Public Type type_SerchTexts
078 sSerchText As String '検索するテキスト
079 iCnt As Long 'ヒットした件数
080 End Type
081
082 ' マージを判断する値
083 Private Const CON_SA1 = 0.5
084 Private Const CON_SA2 = 1 '84%がマージ可能
085 '0.5なら74%がマージ可能
086
087 '座標上のテキストのタイプ ※未使用
088 Public Enum zType
089 iNormal = 0 '通常
090 iItalic = 1 'イタリック
091 iLeft90R = 2 '左90度回転
092 iRight90R = 3 '右90度回転
093 i180R = 4 '１８０度回転
094 iLeft = 5 '左向き(1-89)回転
095 iRight = 6 '右向き(1-89)回転
096 iLeft_2 = 7 '左向き(91-179)回転
097 iRight_2 = 8 '右向き(91-179)回転
098 iEtc = 9 '以外のタイプ
099 End Enum
100
101 '**************************************************
102 '
103 ' Get Texts and Rects from PDF Page
104 '
105 ' テキストを検索し、座標とページ番号を返す。
106 ' 座標はQuadsの形式で返す。
107 '
108 ' Create : 2020/03/25
109 ' Update : 2020/06/09
110 ' Vertion : 3.0.0
111 '
112 ' 引数１ : sPdfFilePath As String (IN)
113 ' 検索するPDFのフルパス
114 ' 引数２ ：iPageStartIn As Long (IN)
115 ' 検索の開始ページ
116 ' 先頭ページは１
117 ' -1は最初から検索
118 ' 引数３ ：iPageEndIn As Long (IN)
119 ' 検索の終了ページ
120 ' -1で最終ページまで検索
121 ' 引数４ ：gSerch(n) As type_SerchTexts
122 ' sSerchText As String：検索する文字列を指定 (IN)
123 ' iCnt As Long：文字列の検索で一致した件数 (OUT)
124 ' 引数５ ：gRects(x) As type_TextRect (OUT)
125 ' 検索した結果
126 ' iPageNo As Long：ページ番号
127 ' iSearchNo As Long：sSerchTextの配列番号のn
128 ' sQuads As String：座標（Quads値）
129 ' 全てカンマ区切り｡８個単位で一組｡
130 ' 引数６ ：iOutCnt As Long (OUT)
131 ' gRectsの登録件数 xの値
132 '
133 ' 戻り値 : True 正常処理
134 ' False エラー処理 PDFで無い
135 '
136 ' 制限 : A)ページにまたがるテキストは検索しない。
137 ' B)半角は大文字小文字を区別する。
138 '
139 ' 注意事項: 以下のURL上に記載。
140 '
141 ' URL : https://pdf-file.nnn2.com/?p=1099
142 '
143 ' 備考 :
144 '
145 ' その他 : 著作権等は主張しません。
146 ' 上記URLにコメントを頂けると嬉しいです。
147 '
148 '**************************************************
149
150 Public Function GetTextsGetRects( _
151 ByVal sPdfFilePath As String, _
152 ByVal iPageStartIn As Long, _
153 ByVal iPageEndIn As Long, _
154 ByRef gSerch() As type_SerchTexts, _
155 ByRef gRects() As type_TextRect, _
156 ByRef iOutCnt As Long) As Boolean
157
158 Dim i1 As Long
159 Dim i2 As Long
160 Dim i3 As Long
161 Dim i4 As Long
162 Dim i5 As Long
163 Dim iOut1 As Long
164 Dim iOut2 As Long
165
166 Dim iRet As Long
167 Dim bRet As Boolean
168 Dim iPageNo As Long
169 Dim iPageCnt As Long
170 Dim iPageStart As Long
171 Dim iPageEnd As Long
172
173 Dim sAJS As String
174 Dim sJsRet As String
175 Dim sJsText As String
176 Dim sJsText_Wk As String
177 Dim sJsWk2() As String
178 Dim sJsWk3() As String
179 Dim sPageTextAll As String
180
181 Dim bCRLF As Boolean
182 Dim bCR As Boolean
183 Dim bLF As Boolean
184 Dim bSpace As Boolean
185 Dim iAddNo As Long
186
187 Dim sTou() As String 'テキスト ※1文字
188 Dim sQou() As String 'Quads値 ※7個以上
189 Dim iMno() As Long 'マージ判断番号
190 Dim sTextWk As String
191 Dim sQuadsWk As String
192
193 'Don't put "this." At the beginning!
194 Const sAcrobatJavaScript = _
195 "var sOut='';" & _
196 "var nWords = getPageNumWords(@P);" & _
197 "for (var j=0; j<nWords; j++) {" & _
198 " nWord=getPageNthWord(@P,j,false);" & _
199 " aQuads =getPageNthWordQuads(@P,j);" & _
200 " sOut=sOut+j+'\b'+nWord+'\b'+aQuads+'\t';" & _
201 "}" & _
202 "event.value=sOut;"
203 '※特殊文字はデータの区切りに使用
204 ' （\b：backspace）（\t：tab）
205
206 If Dir$(sPdfFilePath, vbNormal) = "" Then
207 MsgBox sPdfFilePath & vbCrLf & _
208 "Not found the file!", _
209 vbOKOnly + vbCritical, "実行エラー"
210 GetTextsGetRects = False
211 Exit Function
212 End If
213
214 'Acrobatオブジェクトの定義＆作成
215 '※ここのオブジェクトをグローバル変数にしては駄目！
216 'Acrobat 7,8,9,10,11 の時
217 Dim objAcroApp As New Acrobat.AcroApp
218 Dim objAcroAVDoc As New Acrobat.AcroAVDoc
219 Dim objAcroPDDoc As New Acrobat.AcroPDDoc
220 Dim objAcroPDPage As Acrobat.AcroPDPage
221 Dim objAcroAVPageView As Acrobat.AcroAVPageView
222 Dim objAFormApp As AFORMAUTLib.AFormApp
223 Dim objAFormFields As AFORMAUTLib.Fields
224
225 objAcroApp.CloseAllDocs 'メモリへ強制ロード
226 objAcroApp.Hide '稀にデスクトップに表示されるので隠す
227
228 'PDFファイルを開く
229 If objAcroAVDoc.Open(sPdfFilePath, "") = False Then
230 MsgBox "Can't open!" & vbCrLf & sPdfFilePath, _
231 vbOKOnly + vbCritical, "実行エラー"
232 GetTextsGetRects = False
233 GoTo Skip_GetTextsGetRects_END:
234 End If
235
236 Application.Cursor = xlWait 'マウスポインターを砂時計
237 Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
238 iPageStart = IIf(iPageStartIn = -1, 0, iPageStartIn - 1)
239 iPageEnd = IIf(iPageEndIn = -1, objAcroPDDoc.GetNumPages, iPageEndIn) - 1
240
241 Set objAFormApp = CreateObject("AFormAut.App")
242 '※ココで実行エラー発生時はExcelを再起動し、
243 ' 更にメモリ上のAcrobat.exeを強制終了する。
244 Set objAFormFields = objAFormApp.Fields
245 Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
246
247 ReDim gRects(100) As type_TextRect
248 Dim sJ1_Rt() As type_Js1Rect
249 Dim sJ2_Rt() As type_Js2Rect
250 iOutCnt = -1
251
252 For iPageNo = iPageStart To iPageEnd
253 giMergeNo = -1
254
255 If DG_MD And Int((iPageNo + 1) / 10) = _
256 ((iPageNo + 1) / 10) Then
257 '実行中の状態を表示
258 Debug.Print "Page=" & iPageNo + 1 & " " & Time
259 End If
260 DoEvents
261
262 'Acrobat JavaScriptの編集＆実行
263 sAJS = sAcrobatJavaScript
264 sAJS = Replace(sAJS, "@P", iPageNo)
265 sJsRet = objAFormFields.ExecuteThisJavascript(sAJS)
266
267 '初期化
268 ReDim sJ1_Rt(100) As type_Js1Rect
269 ReDim sJ2_Rt(100) As type_Js2Rect
270 sPageTextAll = ""
271 sJsWk2 = Split(sJsRet, vbTab)
272 iOut1 = -1
273
274 '▼<JS>頁の全文字列を抽出
275 For i1 = 0 To UBound(sJsWk2)
276 If sJsWk2(i1) = "" Then Exit For
277 sJsWk3 = Split(sJsWk2(i1), vbBack)
278 If UBound(sJsWk3) < 2 Then _
279 GoTo GetTextsGetRects_Skip1:
280 sJsText = sJsWk3(1)
281
282 bSpace = (InStr(sJsText, Space(1)) > 0)
283 bCRLF = (InStr(sJsText, vbCrLf) > 0)
284 sJsText_Wk = Replace(sJsText, vbCrLf, "")
285 bLF = (InStr(sJsText_Wk, vbLf) > 0)
286 bCR = (InStr(sJsText_Wk, vbCr) > 0)
287
288 'テキスト
289 sJsText = Replace(sJsText, vbCrLf, "")
290 sJsText = Replace(sJsText, vbLf, "")
291 sJsText = Replace(sJsText, vbCr, "")
292
293 If Trim(sJsText) = "" Then _
294 GoTo GetTextsGetRects_Skip1:
295 'Quads値のデータチェック
296 If Not CheckQuadsData(sJsWk3(2)) Then _
297 GoTo GetTextsGetRects_Skip1:
298 'ダブっているQuads組を削除
299 Call PreprocessingQuads(sJsWk3(2))
300 If sJsWk3(2) = "" Then _
301 GoTo GetTextsGetRects_Skip1:
302
303 'データの保存
304 iOut1 = iOut1 + 1
305 If iOut1 > UBound(sJ1_Rt) Then
306 ReDim Preserve sJ1_Rt(200 + UBound(sJ1_Rt)) _
307 As type_Js1Rect
308 End If
309 With sJ1_Rt(iOut1)
310 .sText = Trim(sJsText) 'ココで空白を削除
311 .sQuads = sJsWk3(2)
312 .iQuadsCnt = UBound(Split(.sQuads, ","))
313 .bSpace = bSpace
314 .bCRLF = bCRLF
315 .bLF = bLF
316 .bCR = bCR
317 End With
318
319 GetTextsGetRects_Skip1:
320 Next i1
321
322 '▼１文字単位に座標を分割
323 iOut2 = -1
324 For i1 = 0 To iOut1
325 With sJ1_Rt(i1)
326 If Len(.sText) = 1 And .iQuadsCnt = 7 Then
327 '▽１文字＋１組Quads値はそのまま使う
328 ReDim sTou(0) As String
329 ReDim sQou(0) As String
330 ReDim iMno(0) As Long
331 sTou(0) = .sText '１文字
332 sQou(0) = .sQuads
333 giMergeNo = giMergeNo + 1
334 iMno(0) = giMergeNo
335 iAddNo = 0
336 ElseIf Len(.sText) > 1 And .iQuadsCnt = 7 Then
337 '▽計算で分割
338 Call SplitQuadsCalc(.sText, .sQuads, sTou, sQou)
339 ReDim iMno(UBound(sTou)) As Long
340 giMergeNo = giMergeNo + 1
341 For i3 = 0 To UBound(sTou)
342 iMno(i3) = giMergeNo
343 Next i3
344 iAddNo = Len(.sText) - 1
345 Else
346 '▽テキストとQuads値を分割
347 Call SplitQuadsText(.sText, .sQuads, _
348 .bSpace, .bCRLF, .bCR, .bLF, sTou, sQou, iAddNo, iMno)
349 End If
350 End With
351
352 '▽検索用のテキスト変数を作成
353 For i3 = 0 To UBound(sTou)
354 sPageTextAll = sPageTextAll & sTou(i3)
355 Next i3
356
357 '▽検索用テキストと１対１の座標配列の「J2」作成
358 For i2 = 0 To UBound(sTou)
359 iOut2 = iOut2 + 1
360 If iOut2 > UBound(sJ2_Rt) Then
361 ReDim Preserve sJ2_Rt(200 + UBound(sJ2_Rt)) _
362 As type_Js2Rect
363 End If
364 With sJ2_Rt(iOut2)
365 .iIndex = i1
366 .sText = sTou(i2)
367 .iMargeNo = iMno(i2)
368 .sQuads = sQou(i2)
369 .iQuadsType = IIf(sQou(i2) = "", _
370 -1, CheckQuadsType(sQou(i2))) 'Debug用
371 ' If UBound(sTou) = 0 Then
372 ' '未分割のQuads値
373 ' .iQuadsIndex = 0
374 ' .iQuadsCalc = 0
375 ' Else
376 ' '分割されたQuads値
377 ' .iQuadsIndex = i2 + 1
378 ' .iQuadsCalc = 1
379 ' End If
380 If i2 = iAddNo Then
381 '指定場所のテキストに終了状態をセット
382 .bSpace = sJ1_Rt(i1).bSpace
383 .bCRLF = sJ1_Rt(i1).bCRLF
384 .bLF = sJ1_Rt(i1).bLF
385 .bCR = sJ1_Rt(i1).bCR
386 Else
387 .bSpace = False
388 .bCRLF = False
389 .bLF = False
390 .bCR = False
391 End If
392 End With
393 Next i2
394 '▽スペース用の座標無し配列を追加
395 If sJ1_Rt(i1).bSpace Then
396 If bCheckKigouSpaceLF(sJ1_Rt(i1).sText, _
397 sJ1_Rt(i1).bSpace, _
398 sJ1_Rt(i1).bCRLF, _
399 sJ1_Rt(i1).bLF) Then
400 '行の最後の文字が記号でスペース＋改行(LF)時は
401 'スペースは入れない。2020/06/09追加
402 Else
403 sPageTextAll = sPageTextAll & Space(1)
404 iOut2 = iOut2 + 1
405 If iOut2 > UBound(sJ2_Rt) Then
406 ReDim Preserve sJ2_Rt(200 + UBound(sJ2_Rt)) _
407 As type_Js2Rect
408 End If
409 With sJ2_Rt(iOut2)
410 .iIndex = -1
411 .sText = " "
412 .sQuads = ""
413 '以下は使わないので未セット
414 ' .iMargeNo = -1
415 ' .iQuadsType = 0
416 ' .iQuadsIndex = 0
417 ' .iQuadsCalc = 0
418 ' .bSpace = False
419 ' .bCRLF = False
420 ' .bLF = False
421 ' .bCR = False
422 End With
423 End If
424 End If
425
426 Next i1
427
428 '▼検索テキストから座標を出す
429 Dim sWk_Quads() As String
430 Dim iJ2_MergeNo As Long
431 Dim iStart As Long
432
433 iStart = 1
434 For i1 = 0 To UBound(gSerch)
435 If Trim(gSerch(i1).sSerchText) = "" Then GoTo Search_Skip:
436 i2 = InStr(iStart, sPageTextAll, gSerch(i1).sSerchText)
437 If i2 = 0 Then
438 '見つからない
439 iStart = 1
440 Else
441 '見つかった
442 gSerch(i1).iCnt = gSerch(i1).iCnt + 1
443 iStart = i2 + 1
444 i2 = i2 - 1
445 'Quadsを集計
446 sQuadsWk = ""
447 For i3 = i2 To i2 + Len(gSerch(i1).sSerchText) - 1
448 If sJ2_Rt(i3).sQuads = "" Then
449 '空白の座標を計算で追加する 非マージ対象
450 Call AddQuadsSpace(sQuadsWk, sJ2_Rt(i3 + 1).sQuads, _
451 sJ2_Rt(i3 - 1).bCRLF, sJ2_Rt(i3 - 1).bLF)
452 Else
453 If i3 = i2 Then
454 '初回のみの処理
455 iJ2_MergeNo = sJ2_Rt(i3).iMargeNo
456 sQuadsWk = sJ2_Rt(i3).sQuads
457 Else
458 '2回目以降の処理
459 If iJ2_MergeNo = sJ2_Rt(i3).iMargeNo Then
460 '★マージ連番が前回と同じ＝>マージする
461 Call MargeSameQuads8(sQuadsWk, sJ2_Rt(i3).sQuads)
462 Else
463 If sQuadsWk <> "" Then sQuadsWk = sQuadsWk & ","
464 sQuadsWk = sQuadsWk & sJ2_Rt(i3).sQuads
465 End If
466 iJ2_MergeNo = sJ2_Rt(i3).iMargeNo
467 End If
468 End If
469 Next i3
470 '結果を戻り値にセット
471 iOutCnt = iOutCnt + 1
472 If iOutCnt > UBound(gRects) Then
473 ReDim Preserve gRects( _
474 100 + UBound(gRects)) As type_TextRect
475 End If
476 With gRects(iOutCnt)
477 .iPageNo = iPageNo
478 .sQuads = sQuadsWk
479 .iSearchNo = i1
480 End With
481 End If
482 If iStart > 1 Then
483 '同じ検索テキストで次の位置から再検索する
484 i1 = i1 - 1
485 End If
486 Search_Skip:
487 Next i1
488 Next iPageNo
489
490 'マージ可能Quadsを処理
491 Call CheckQuads_Merge2(gRects)
492
493 Application.Cursor = xlDefault 'マウスポインターを戻す
494 'PDFファイルを閉じる
495 If objAcroAVDoc.Close(False) = False Then
496 MsgBox "AVDocオブジェクトはClose出来ませんでした", _
497 vbOKOnly + vbCritical, "実行エラー"
498 GetTextsGetRects = False
499 End If
500
501 Skip_GetTextsGetRects_END:
502
503 On Error Resume Next 'これ以降は強制実行
504 Application.Cursor = xlDefault 'マウスポインターを戻す
505 '変更しないで閉じます。
506 bRet = objAcroAVDoc.Close(False)
507 'Acrobatアプリケーションの終了
508 objAcroApp.Hide
509 objAcroApp.Exit
510 'オブジェクトの開放
511 Set objAFormFields = Nothing
512 Set objAFormApp = Nothing
513 Set objAcroAVPageView = Nothing
514 Set objAcroPDPage = Nothing
515 Set objAcroPDDoc = Nothing
516 Set objAcroAVDoc = Nothing
517 Set objAcroApp = Nothing
518
519 If DG_MD Then
520 Debug.Print "iOutCnt=" & (iOutCnt + 1)
521 End If
522
523 ' Exit Function
524 'Err_GetTextsGetRects:
525 ' MsgBox "処理は以下の理由で中断しました。" & vbCrLf & _
526 ' vbCrLf & Err.Number & vbCrLf & Err.Description, _
527 ' vbOKOnly + vbCritical, "実行エラー"
528 ' GetTextsGetRects = False
529 ' GoTo Skip_GetTextsGetRects_END:
530 End Function
531
532 '**************************************************
533 '
534 ' 最後の文字が記号で更にスペースを含んだ改行かを
535 ' 判断する。
536 '
537 ' Create : 2020/06/09
538 ' Version: 1.0.0
539 '**************************************************
540 'Sub test_bCheckKigouSpaceLF()
541 ' Debug.Print bCheckKigouSpaceLF("AB-", True, True, True)
542 ' Debug.Print bCheckKigouSpaceLF("ABC", True, True, True)
543 ' Debug.Print bCheckKigouSpaceLF("AB全", True, True, True)
544 'End Sub
545 Private Function bCheckKigouSpaceLF( _
546 ByVal sText As String, _
547 ByVal bSpace As Boolean, _
548 ByVal bCRLF As Boolean, _
549 ByVal bLF As Boolean) As Boolean
550
551 Dim sWk As String
552 sWk = Right(sText, 1)
553 If Len(sWk) <> LenB(StrConv(sWk, vbFromUnicode)) Then
554 '全角文字
555 bCheckKigouSpaceLF = False
556 Exit Function
557 End If
558 Dim sCode As String
559 '文字コードを取得
560 sCode = Asc(sWk)
561 '文字コードで半角英数字のチェック
562 If (sCode >= 48 And sCode <= 57) Then
563 '半角 0～9
564 bCheckKigouSpaceLF = False
565 ElseIf (sCode >= 65 And sCode <= 90) Then
566 '半角 A～Z 英字大文字
567 bCheckKigouSpaceLF = False
568 ElseIf (sCode >= 97 And sCode <= 122) Then
569 '半角 a～z 英字小文字
570 bCheckKigouSpaceLF = False
571 Else
572 '半角記号
573 If bSpace And bLF Then
574 bCheckKigouSpaceLF = True
575 Else
576 bCheckKigouSpaceLF = False
577 End If
578 End If
579 End Function
580
581 '**************************************************
582 '
583 ' マージできるQuads値を探して、処理する。
584 '
585 ' 前後のQuads値の隣接する座標を比較し、
586 ' 差が全て 1.0 以内ならばマージする'
587 '
588 ' Create : 2020/06/07
589 ' Version: 1.0.0
590 '
591 ' 比較する箇所：
592 ' 前の座標 後の座標
593 ' 2x <-> 1x
594 ' 2y <-> 1y
595 ' 4x <-> 3x
596 ' 4y <-> 3y
597 '**************************************************
598 Private Sub CheckQuads_Merge2( _
599 ByRef gRects() As type_TextRect)
600
601 Dim i1 As Long
602 Dim i2 As Long
603 Dim i3 As Long
604 Dim i4 As Long
605 Dim sWk1() As String
606 Dim sWk2() As String
607 Dim bMerge As Boolean 'True：マージ処理をした
608
609 For i1 = 0 To UBound(gRects)
610 bMerge = False
611 sWk1 = Split(gRects(i1).sQuads, ",")
612 If UBound(sWk1) > 7 Then
613 ReDim sWk2(UBound(sWk1)) As String
614 For i2 = 0 To 7
615 sWk2(i2) = sWk1(i2)
616 sWk1(i2) = ""
617 Next i2
618 i2 = 8
619 i3 = 0
620 Do Until i2 > UBound(sWk1)
621 '隣接する部分の差を比較
622 If Abs(Val(sWk2(i3 + 2)) - Val(sWk1(i2 + 0))) < CON_SA2 And _
623 Abs(Val(sWk2(i3 + 3)) - Val(sWk1(i2 + 1))) < CON_SA2 And _
624 Abs(Val(sWk2(i3 + 6)) - Val(sWk1(i2 + 4))) < CON_SA2 And _
625 Abs(Val(sWk2(i3 + 7)) - Val(sWk1(i2 + 5))) < CON_SA2 Then
626 '２つの座標をマージする
627 ' sWk2(i3 + 0) = sWk1(i2 + 0) '1x
628 ' sWk2(i3 + 1) = sWk1(i2 + 1) '1y
629 sWk2(i3 + 2) = sWk1(i2 + 2) '2x
630 sWk2(i3 + 3) = sWk1(i2 + 3) '2y
631 ' sWk2(i3 + 4) = sWk1(i2 + 4) '3x
632 ' sWk2(i3 + 5) = sWk1(i2 + 5) '3y
633 sWk2(i3 + 6) = sWk1(i2 + 6) '4x
634 sWk2(i3 + 7) = sWk1(i2 + 7) '4y
635 i2 = i2 + 8
636 bMerge = True
637 Else
638 'マージできないのでそのままコピー
639 i3 = i3 + 8
640 For i4 = 0 To 7
641 sWk2(i3 + i4) = sWk1(i2)
642 sWk1(i2) = ""
643 i2 = i2 + 1
644 Next i4
645 End If
646 Loop
647 If bMerge Then
648 'マージ処理をしたので結果を返す
649 With gRects(i1)
650 .sQuads = ""
651 For i2 = 0 To UBound(sWk2)
652 If sWk2(i2) <> "" Then
653 If .sQuads <> "" Then _
654 .sQuads = .sQuads & ","
655 .sQuads = .sQuads & sWk2(i2)
656 End If
657 Next i2
658 End With
659 End If
660 End If
661 Next i1
662 End Sub
663
664 '**************************************************
665 '
666 ' 空白の座標を追加する。
667 '
668 ' 最初のQuads値の後８座標の2x,2y,4x,4y と
669 ' 後 のQuads値の前８座標の1x,1y,3x,3y を使って
670 ' 間の空白用の座標を作成する。
671 ' 但し、次が改行の時はマージ可能座標を追加する。
672 '
673 ' Create : 2020/06/09
674 ' Version: 1.0.0
675 '
676 '**************************************************
677 Private Sub AddQuadsSpace( _
678 ByRef sQuads As String, _
679 ByVal sQuads_AF As String, _
680 ByVal bCRLF As Boolean, _
681 ByVal bLF As Boolean)
682
683 Dim sWk1() As String
684 Dim sWk2() As String
685 Dim sSpace(7) As String
686 Dim i1 As Long
687
688 sWk1 = Split(Trim(sQuads), ",")
689 sWk2 = Split(Trim(sQuads_AF), ",")
690 i1 = UBound(sWk1) - 7
691 sSpace(0) = sWk1(i1 + 2) '1x
692 sSpace(1) = sWk1(i1 + 3) '1y
693 If bCRLF Or bLF Then
694 sSpace(2) = sSpace(0) '2x
695 sSpace(3) = sSpace(1) '2y
696 Else
697 sSpace(2) = sWk2(0) '2x
698 sSpace(3) = sWk2(1) '2y
699 End If
700 sSpace(4) = sWk1(i1 + 6) '3x
701 sSpace(5) = sWk1(i1 + 7) '3y
702 If bCRLF Or bLF Then
703 sSpace(6) = sSpace(4) '2x
704 sSpace(7) = sSpace(5) '2y
705 Else
706 sSpace(6) = sWk2(4) '4x
707 sSpace(7) = sWk2(5) '4y
708 End If
709 For i1 = 0 To 7
710 sQuads = sQuads & "," & sSpace(i1)
711 Next i1
712 End Sub
713
714 '**************************************************
715 '
716 ' ２つのQuads値をマージ
717 '
718 ' 以下のAが出来たらBはスキップ。
719 ' 以下のAが出来ない時はBを試す。
720 '
721 ' A)S2の全てのQuads値＝S2と同じ数の後のQuads値
722 ' S1にS2の値が含まれている、として
723 ' そのままS1を返す。※J1-J2パターン(E)に対応
724 '
725 ' B)最初のQuads値の後８座標の2x,2y,4x,4y を
726 ' 後のQuads値の前８座標の2x,2y,4x,4y に置き換える。
727 '
728 ' Create : 2020/06/07
729 ' Version: 1.0.0
730 '
731 '**************************************************
732 Private Sub MargeSameQuads8( _
733 ByRef sQuads As String, _
734 ByVal sQuads_Add As String)
735
736 Dim sWk1() As String
737 Dim sWk2() As String
738 Dim i1 As Long
739 Dim i2 As Long
740 Dim i3 As Long
741 Dim i4 As Long
742
743 sWk1 = Split(Trim(sQuads), ",")
744 sWk2 = Split(Trim(sQuads_Add), ",")
745 i1 = UBound(sWk1)
746 i2 = UBound(sWk2)
747
748 'A) 何もしない
749 If i1 >= i2 Then
750 i4 = i1
751 For i3 = UBound(sWk2) To 0 Step -1
752 If sWk1(i4) <> sWk2(i3) Then _
753 GoTo MargeSameQuads8_Skip:
754 i4 = i4 - 1
755 Next i3
756 Exit Sub
757 End If
758
759 MargeSameQuads8_Skip:
760 'B) マージ
761 ' sWk1(i1 - 7) = '1x
762 ' sWk1(i1 - 6) = '1y
763 sWk1(i1 - 5) = sWk2(2) '2x
764 sWk1(i1 - 4) = sWk2(3) '2y
765 ' sWk1(i1 - 3) = '3x
766 ' sWk1(i1 - 2) = '3y
767 sWk1(i1 - 1) = sWk2(6) '4x
768 sWk1(i1 - 0) = sWk2(7) '4y
769 '結果を戻す
770 sQuads = ""
771 For i1 = 0 To UBound(sWk1)
772 If sQuads <> "" Then sQuads = sQuads & ","
773 sQuads = sQuads & sWk1(i1)
774 Next i1
775 End Sub
776
777 '**************************************************
778 '
779 ' テキストとQuads値を分割する
780 '
781 ' Create : 2020/06/07
782 ' Version: 1.0.0
783 '
784 ' テキストとQuads値だけを分割する。
785 ' 他の情報は呼び出し元で追加等をする。
786 '
787 ' iAddNpについて：
788 ' １文字テキスト単位での終了状態を判断する時の
789 ' 位置を示す。J2のテキストの終了状態はこの値で
790 ' セットした位置で判断できるようにする。
791 ' しかし実際はJ2では見なく、J1の配列を見て判断
792 ' しているので、この結果は反映されてない。
793 '
794 '**************************************************
795 Private Sub SplitQuadsText( _
796 ByVal sTextIn As String, _
797 ByVal sQuadsIn As String, _
798 ByVal bSpace As Boolean, _
799 ByVal bCRLF As Boolean, _
800 ByVal bCR As Boolean, _
801 ByVal bLF As Boolean, _
802 ByRef sTextOut() As String, _
803 ByRef sQuadsOut() As String, _
804 ByRef iAddNo As Long, _
805 ByRef iMno() As Long)
806
807 sTextIn = Trim(sTextIn)
808 sQuadsIn = Trim(sQuadsIn)
809 ReDim sTextOut(0) As String
810 ReDim sQuadsOut(0) As String
811 sTextOut(0) = sTextIn
812 sQuadsOut(0) = sQuadsIn
813
814 If Trim(sQuadsIn) = "" Or _
815 Trim(sTextIn) = "" Then
816 Stop 'プログラムエラー
817 Exit Sub
818 End If
819
820 Dim sQin() As String
821 sQin = Split(sQuadsIn, ",")
822 If UBound(sQin) = 7 Then
823 Stop 'プログラムエラー
824 Exit Sub
825 End If
826 If UBound(sQin) < 7 Then
827 'Quads値の数が７以下
828 Stop 'プログラムエラー
829 Exit Sub
830 End If
831 If (UBound(sQin) + 1) / 8 <> _
832 Int((UBound(sQin) + 1) / 8) Then
833 'Quads値の数が８の倍数で無い
834 Stop 'プログラムエラー
835 Exit Sub
836 End If
837
838 Dim i1 As Long
839 Dim i3 As Long
840 i1 = (UBound(sQin) + 1) / 8
841
842 '▼(B)文字数＝Quadsの組数
843 If Len(sTextIn) = i1 Then
844 ReDim sTextOut(i1 - 1) As String
845 ReDim sQuadsOut(i1 - 1) As String
846 ReDim iMno(i1 - 1) As Long
847 For i3 = 0 To i1 - 1
848 sTextOut(i3) = Mid(sTextIn, i3 + 1, 1)
849 sQuadsOut(i3) = SlplitQuads_8Item(sQuadsIn, i3)
850 giMergeNo = giMergeNo + 1
851 iMno(i3) = giMergeNo
852 Next i3
853 iAddNo = Len(sTextIn) - 1
854 Exit Sub
855 End If
856
857 '▼(A)文字数＜Quadsの組数 ※稀に有る
858 If Len(sTextIn) < i1 Then
859 i1 = Len(sTextIn) 'テキストの長さに合わせる
860 ReDim sTextOut(i1 - 1) As String
861 ReDim sQuadsOut(i1 - 1) As String
862 ReDim iMno(i1 - 1) As Long
863 For i3 = 0 To i1 - 1
864 sTextOut(i3) = Mid(sTextIn, i3 + 1, 1)
865 sQuadsOut(i3) = SlplitQuads_8Item(sQuadsIn, i3)
866 giMergeNo = giMergeNo + 1
867 iMno(i3) = giMergeNo
868 Next i3
869 '残りを最後に追加
870 For i3 = i1 To ((UBound(sQin) + 1) / 8) - 1
871 sQuadsOut(i1 - 1) = sQuadsOut(i1 - 1) _
872 & "," & SlplitQuads_8Item(sQuadsIn, i3)
873 Next i3
874 iAddNo = Len(sTextIn) - 1
875 Exit Sub
876 End If
877
878 Dim i2 As Long
879 Dim iCnt As Long
880 Dim sCode As String
881 Dim sWk() As String
882
883 Dim bAlphabetic As Boolean '半角英字
884 Dim iAlphabeticCnt As Long '半角英字の数
885 Dim bNumber As Boolean '半角数字
886 Dim iNumberCnt As Long '半角数字の数
887 Dim bUppercase As Boolean '半角英字大文字
888 Dim iUppercaseCnt As Long '半角英字大文字の数
889 Dim blowercase As Boolean '半角英字小文字
890 Dim ilowercaseCnt As Long '半角英字小文字の数
891 Dim bSymbol As Boolean '半角記号
892 Dim iSymbolCnt As Long '半角記号の数
893 Dim sSymbol As String '最初に見つかった半角記号の内容
894 Dim iSymbolFirst As Long '最初に見つかった半角記号の位置
895
896 bAlphabetic = False
897 bNumber = False
898 bUppercase = False
899 blowercase = False
900 bSymbol = False
901
902 iAlphabeticCnt = 0
903 iNumberCnt = 0
904 iUppercaseCnt = 0
905 ilowercaseCnt = 0
906 iSymbolCnt = 0
907 sSymbol = ""
908 iSymbolFirst = 0
909
910 '▽テキスト内の文字種をチェック
911 i1 = 1
912 Do While i1 <= Len(sTextIn)
913 '１文字単位で文字コードを取得
914 sCode = Asc(Mid(sTextIn, i1, 1))
915 '文字コードで半角英数字のチェック
916 If (sCode >= 48 And sCode <= 57) Then
917 '半角 0～9
918 bNumber = True
919 iNumberCnt = iNumberCnt + 1
920 ElseIf (sCode >= 65 And sCode <= 90) Then
921 '半角 A～Z 英字大文字
922 bAlphabetic = True
923 bUppercase = True
924 iAlphabeticCnt = iAlphabeticCnt + 1
925 iUppercaseCnt = iUppercaseCnt + 1
926 ElseIf (sCode >= 97 And sCode <= 122) Then
927 '半角 a～z 英字小文字
928 bAlphabetic = True
929 blowercase = True
930 iAlphabeticCnt = iAlphabeticCnt + 1
931 ilowercaseCnt = ilowercaseCnt + 1
932 Else
933 '半角記号
934 bSymbol = True
935 iSymbolCnt = iSymbolCnt + 1
936 If sSymbol = "" Then
937 '最初の記号の内容と位置
938 sSymbol = Mid(sTextIn, i1, 1)
939 iSymbolFirst = i1
940 End If
941 End If
942 i1 = i1 + 1
943 Loop
944
945 Dim sWk_Text() As String
946 Dim sWk_Quads() As String
947 Dim sTou() As String
948 Dim sQou() As String
949
950 '▼(C)継続文字「英字＋ハイフン＋英字」の分割
951 If (UBound(sQin) = 15 And _
952 bAlphabetic = True And _
953 sSymbol = "-" And _
954 1 < iSymbolFirst) And _
955 iSymbolFirst < Len(sTextIn) And _
956 (bSpace Or (bSpace And bLF) Or bCRLF) Then
957
958 ReDim sWk_Text(1) As String
959 ReDim sWk_Quads(1) As String
960 sWk_Text(0) = Left(sTextIn, iSymbolFirst - 1)
961 sWk_Text(1) = Mid(sTextIn, iSymbolFirst + 1)
962 sWk_Quads(0) = SlplitQuads_8Item(sQuadsIn, 0)
963 'ハイフン分のQuads値を削除する
964 sWk_Quads(0) = CutHaifunQ(sWk_Quads(0), iSymbolFirst)
965 sWk_Quads(1) = SlplitQuads_8Item(sQuadsIn, 1)
966
967 '１文字単位に分割
968 i1 = Len(sTextIn) - 2
969 ReDim sTextOut(i1) As String
970 ReDim sQuadsOut(i1) As String
971 ReDim iMno(i1) As Long
972 iCnt = -1
973 For i2 = 0 To 1
974 giMergeNo = giMergeNo + 1
975 If Len(sWk_Text(i2)) = 1 Then
976 iCnt = iCnt + 1
977 sTextOut(iCnt) = sWk_Text(i2)
978 sQuadsOut(iCnt) = sWk_Quads(i2)
979 iMno(iCnt) = giMergeNo
980 Else
981 Call SplitQuadsCalc(sWk_Text(i2), sWk_Quads(i2), sTou, sQou)
982 For i3 = 0 To UBound(sTou)
983 iCnt = iCnt + 1
984 sTextOut(iCnt) = sTou(i3)
985 sQuadsOut(iCnt) = sQou(i3)
986 iMno(iCnt) = giMergeNo
987 Next i3
988 End If
989 If i2 = 0 Then iAddNo = iCnt
990 Next i2
991 Exit Sub
992 End If
993
994 '▼(D)大文字英字＋小文字英字＋大文字英字
995 Dim sWk2() As String
996 ReDim sWk2(Len(sTextIn)) As String
997 i2 = -1
998 For i1 = 1 To Len(sTextIn)
999 '１文字の文字コードを取得
1000 sCode = Asc(Mid(sTextIn, i1, 1))
1001 '文字コードで半角英数字のチェック
1002 If (sCode >= 65 And sCode <= 90) Then
1003 '半角英字(A～Z)
1004 i2 = i2 + 1
1005 sWk2(i2) = Mid(sTextIn, i1, 1)
1006 Else
1007 '半角英字(A～Z)以外
1008 If i2 = -1 Then i2 = 0
1009 sWk2(i2) = sWk2(i2) & Mid(sTextIn, i1, 1)
1010 End If
1011 Next i1
1012 If (UBound(sQin) + 1) / 8 = (i2 + 1) Then
1013 '大文字で区切るとQuads組数と同じ
1014 ReDim sWk_Text(i2) As String
1015 ReDim sWk_Quads(i2) As String
1016 '１文字が１Quads値
1017 For i3 = 0 To i2
1018 sWk_Text(i3) = sWk2(i3)
1019 sWk_Quads(i3) = SlplitQuads_8Item(sQuadsIn, i3)
1020 Next i3
1021 iCnt = -1
1022 ReDim sTextOut(Len(sTextIn) - 1) As String
1023 ReDim sQuadsOut(Len(sTextIn) - 1) As String
1024 ReDim iMno(Len(sTextIn) - 1) As Long
1025 For i1 = 0 To i2
1026 Call SplitQuadsCalc( _
1027 sWk_Text(i1), sWk_Quads(i1), sTou, sQou)
1028 giMergeNo = giMergeNo + 1
1029 For i3 = 0 To UBound(sTou)
1030 iCnt = iCnt + 1
1031 sTextOut(iCnt) = sTou(i3)
1032 sQuadsOut(iCnt) = sQou(i3)
1033 iMno(iCnt) = giMergeNo
1034 Next i3
1035 Next i1
1036 iAddNo = iCnt
1037 Exit Sub
1038 End If
1039
1040 '▼(E)分割できないQuads値
1041 ' 文字数＞Quadsの組数 ※かなり有る
1042 If Len(sTextIn) > ((UBound(sQin) + 1) / 8) Then
1043 ReDim sTextOut(Len(sTextIn) - 1) As String
1044 ReDim sQuadsOut(Len(sTextIn) - 1) As String
1045 ReDim iMno(Len(sTextIn) - 1) As Long
1046 giMergeNo = giMergeNo + 1
1047 For i3 = 0 To Len(sTextIn) - 1
1048 sTextOut(i3) = Mid(sTextIn, i3 + 1, 1)
1049 sQuadsOut(i3) = sQuadsIn
1050 iMno(i3) = giMergeNo
1051 Next i3
1052 iAddNo = Len(sTextIn) - 1
1053 Exit Sub
1054 End If
1055
1056 Stop 'プログラムエラー
1057 End Sub
1058
1059 '**************************************************
1060 '
1061 ' Quads値の右端から1文字分の座標を削除する。
1062 '
1063 ' Create : 2020/06/07
1064 ' Version: 1.0.0
1065 '
1066 ' テキスト途中にハイフンが入ったテキストの
1067 ' ハイフン前のテキスト用のQuads座標から
1068 ' ハイフンの１文字分の座標を削除する。
1069 '
1070 '**************************************************
1071 Private Function CutHaifunQ( _
1072 ByVal sQu As String, _
1073 ByVal iLen As Long) As String
1074
1075 Dim i1 As Long
1076 Dim iX1 As Double
1077 Dim iX2 As Double
1078 Dim iY1 As Double
1079 Dim iY2 As Double
1080 Dim sWk() As String
1081
1082 If Trim(sQu) = "" Then Stop
1083 If iLen = 0 Then Stop
1084 sWk = Split(sQu, ",")
1085 iX1 = (Val(sWk(JZ2.i2x)) - Val(sWk(JZ2.i1x))) / iLen
1086 iX2 = (Val(sWk(JZ2.i4x)) - Val(sWk(JZ2.i3x))) / iLen
1087 iY1 = (Val(sWk(JZ2.i2y)) - Val(sWk(JZ2.i1y))) / iLen
1088 iY2 = (Val(sWk(JZ2.i4y)) - Val(sWk(JZ2.i3y))) / iLen
1089 CutHaifunQ = sWk(JZ2.i1x)
1090 CutHaifunQ = CutHaifunQ & "," & sWk(JZ2.i1y)
1091 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i2x) - iX1)
1092 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i2y) - iY1)
1093 CutHaifunQ = CutHaifunQ & "," & sWk(JZ2.i3x)
1094 CutHaifunQ = CutHaifunQ & "," & sWk(JZ2.i3y)
1095 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i4x) - iX2)
1096 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i4y) - iY2)
1097 End Function
1098
1099 '**************************************************
1100 '
1101 ' Quads値の整合性をチェックする
1102 '
1103 ' Create : 2020/06/07
1104 ' Version: 1.0.0
1105 '
1106 ' 戻り値 ：True エラー無し
1107 ' ：False エラー有り
1108 '
1109 '**************************************************
1110 Private Function CheckQuadsData( _
1111 ByVal sQuads As String) As Boolean
1112 On Error GoTo Err_CheckQuadsData:
1113 Dim sWk() As String
1114 Dim i1 As Long
1115 If Trim(sQuads) = "" Then
1116 CheckQuadsData = False
1117 Exit Function
1118 End If
1119 '配列が８の倍数
1120 sWk = Split(sQuads, ",")
1121 If UBound(sWk) < 7 Or _
1122 (Int((UBound(sWk) + 1) / 8) <> ((UBound(sWk) + 1) / 8)) Then
1123 CheckQuadsData = False
1124 Exit Function
1125 End If
1126 'データが数値
1127 For i1 = 0 To UBound(sWk)
1128 If Not IsNumeric(sWk(i1)) Or _
1129 Trim(sWk(i1)) = "" Then
1130 CheckQuadsData = False
1131 Exit Function
1132 End If
1133 Next i1
1134 CheckQuadsData = True
1135 Exit Function
1136
1137 Err_CheckQuadsData:
1138 CheckQuadsData = False
1139 End Function
1140
1141 '**************************************************
1142 '
1143 ' Quads値の前処理
1144 '
1145 ' 1組のQuads値の前後の差が0.5以内ならば
1146 ' 同じQuads組と扱い、後のQuads値を削除する。
1147 ' 削除後は空いた部分に後を詰める。
1148 '
1149 ' Create : 2020/06/07
1150 ' Version: 1.0.0
1151 '
1152 ' 稀だがこの様なQuads値が存在する。削除する。
1153 '
1154 '**************************************************
1155 Private Sub PreprocessingQuads(ByRef sQuads As String)
1156 Dim sWk() As String
1157 Dim i1 As Long
1158 Dim i2 As Long
1159 Dim i3 As Long
1160 Dim i4 As Long
1161 Dim bDel As Boolean
1162 Dim iSkip As Long
1163
1164 sWk = Split(sQuads, ",")
1165 If UBound(sWk) = 7 Then Exit Sub
1166
1167 bDel = False
1168 For i1 = 0 To ((UBound(sWk) + 1) / 8 - 1)
1169 If sWk((i1 + 1) * 8) = "" Then Exit For
1170 iSkip = 0
1171 For i2 = 0 To 7
1172 If Abs(Val(sWk((i1 * 8) + i2)) - _
1173 Val(sWk(((i1 + 1) * 8) + i2))) < CON_SA1 Then
1174 iSkip = iSkip + 1
1175 End If
1176 Next i2
1177
1178 If iSkip = 8 Then
1179 '同じQuads値は削除する
1180 bDel = True
1181 For i3 = 0 To 7
1182 sWk((i1 + 1) * 8 + i3) = ""
1183 Next i3
1184 If ((i1 + 1) * 8 + 8) >= UBound(sWk) Then Exit For
1185
1186 '同じQuads値は無視して、前に詰める
1187 For i3 = (i1 + 1) To ((UBound(sWk) + 1) / 8 - 2)
1188 For i4 = 0 To 7
1189 sWk(i3 * 8 + i4) = sWk((i3 + 1) * 8 + i4)
1190 sWk((i3 + 1) * 8 + i4) = ""
1191 Next i4
1192 Next i3
1193 i1 = i1 - 1
1194 End If
1195 If (i1 + 1) >= ((UBound(sWk) + 1) / 8 - 1) Then Exit For
1196 Next i1
1197
1198 If bDel Then
1199 'Quads値を戻す
1200 sQuads = ""
1201 For i1 = 0 To UBound(sWk)
1202 If sWk(i1) <> "" Then
1203 If sQuads <> "" Then sQuads = sQuads & ","
1204 sQuads = sQuads & sWk(i1)
1205 End If
1206 Next i1
1207 End If
1208 End Sub
1209
1210 '**************************************************
1211 '
1212 ' テキストを１文字単位で分割し、
1213 ' Quads値を計算で出す。
1214 '
1215 ' 1)テキストが２文字以上：例「ABC」
1216 ' 2)Quads数＝８ ：例「1,2,3,4,5,6,7,8」
1217 '
1218 ' Create : 2020/06/07
1219 ' Version: 1.0.0
1220 '
1221 '**************************************************
1222 Public Sub SplitQuadsCalc( _
1223 ByVal sTextIn As String, _
1224 ByVal sQuadsIn As String, _
1225 ByRef sTou() As String, _
1226 ByRef sQou() As String)
1227
1228 Dim i1 As Long
1229 Dim sWk() As String
1230 Dim iX1 As Double
1231 Dim iX2 As Double
1232 Dim iY1 As Double
1233 Dim iY2 As Double
1234
1235 sTextIn = Trim$(sTextIn)
1236 If sTextIn = "" Then Stop
1237 sQuadsIn = Trim$(sQuadsIn)
1238 If sQuadsIn = "" Then Stop
1239
1240 sWk = Split(sQuadsIn, ",")
1241 ' If Len(sTextIn) = 1 Or _
1242 ' UBound(sWk) <> 7 Then Stop
1243
1244 ReDim sTou(Len(sTextIn) - 1) As String
1245 ReDim sQou(Len(sTextIn) - 1) As String
1246 If Len(sTextIn) = 1 Then
1247 sTou(0) = sTextIn
1248 sQou(0) = sQuadsIn
1249 Exit Sub
1250 End If
1251 iX1 = (Val(sWk(JZ2.i2x)) - Val(sWk(JZ2.i1x))) / Len(sTextIn)
1252 iX2 = (Val(sWk(JZ2.i4x)) - Val(sWk(JZ2.i3x))) / Len(sTextIn)
1253 iY1 = (Val(sWk(JZ2.i2y)) - Val(sWk(JZ2.i1y))) / Len(sTextIn)
1254 iY2 = (Val(sWk(JZ2.i4y)) - Val(sWk(JZ2.i3y))) / Len(sTextIn)
1255 For i1 = 0 To UBound(sTou)
1256 sTou(i1) = Mid(sTextIn, i1 + 1, 1)
1257 sQou(i1) = ""
1258 sQou(i1) = sQou(i1) & IIf(i1 = 0, _
1259 sWk(JZ2.i1x), Val(sWk(JZ2.i1x)) + (iX1 * i1))
1260 sQou(i1) = sQou(i1) & "," & IIf(i1 = 0, _
1261 sWk(JZ2.i1y), Val(sWk(JZ2.i1y)) + (iY1 * i1))
1262 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1263 sWk(JZ2.i2x), Val(sWk(JZ2.i1x)) + (iX1 * (i1 + 1)))
1264 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1265 sWk(JZ2.i2y), Val(sWk(JZ2.i1y)) + (iY1 * (i1 + 1)))
1266 sQou(i1) = sQou(i1) & "," & IIf(i1 = 0, _
1267 sWk(JZ2.i3x), Val(sWk(JZ2.i3x)) + (iX2 * i1))
1268 sQou(i1) = sQou(i1) & "," & IIf(i1 = 0, _
1269 sWk(JZ2.i3y), Val(sWk(JZ2.i3y)) + (iY2 * i1))
1270 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1271 sWk(JZ2.i4x), Val(sWk(JZ2.i3x)) + (iX2 * (i1 + 1)))
1272 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1273 sWk(JZ2.i4y), Val(sWk(JZ2.i3y)) + (iY2 * (i1 + 1)))
1274 Next i1
1275 End Sub
1276
1277 '**************************************************
1278 '
1279 ' Quads値の整合性をチェックする
1280 '
1281 ' Create : 2020/06/07
1282 ' Version: 1.0.0
1283 '
1284 ' 戻り値 ：True エラー無し
1285 ' ：False エラー有り
1286 '
1287 '**************************************************
1288 Public Function CheckQuads( _
1289 ByVal sQuads As String) As Boolean
1290 On Error GoTo Err_CheckQuads:
1291 Dim sWk() As String
1292 Dim i1 As Long
1293 If Trim(sQuads) = "" Then
1294 CheckQuads = False
1295 Exit Function
1296 End If
1297 '配列が８の倍数
1298 sWk = Split(sQuads, ",")
1299 If UBound(sWk) < 7 Or _
1300 (Int((UBound(sWk) + 1) / 8) <> ((UBound(sWk) + 1) / 8)) Then
1301 CheckQuads = False
1302 Exit Function
1303 End If
1304 'データが数値
1305 For i1 = 0 To UBound(sWk)
1306 If Not IsNumeric(sWk(i1)) Or _
1307 Trim(sWk(i1)) = "" Then
1308 CheckQuads = False
1309 Exit Function
1310 End If
1311 Next i1
1312 CheckQuads = True
1313 Exit Function
1314 Err_CheckQuads:
1315 CheckQuads = False
1316 End Function
1317
1318 '**************************************************
1319 '
1320 ' 文字列のQuads値を８座標単位で分割して返す関数
1321 '
1322 ' sQuads：Quads値が入った文字列
1323 ' iIchi ：抽出位置。0から開始
1324 '
1325 ' Create : 2020/06/07
1326 ' Version: 1.0.0
1327 '
1328 '**************************************************
1329 'Sub Test_SlplitQuads()
1330 ' Debug.Print "(" & SlplitQuads_8Item("1,2,3,4,5,6,7,8," & _
1331 ' "9,10,11,12,13,14,15,16,17,18,19,20," & _
1332 ' "21,22,23,24,25,26,27,28,29", _
1333 ' 0) & ")"
1334 '' 以下は実行結果
1335 '' (17,18,19,20,21,22,23,24)
1336 '' (1,2,3,4,5,6,7,8)
1337 '' (9,10,11,12,13,14,15,16)
1338 'End Sub
1339 Public Function SlplitQuads_8Item( _
1340 ByVal sQuads As String, _
1341 ByVal iIchi As Long) As String
1342
1343 Dim sWk() As String
1344 Dim i1 As Long
1345 iIchi = iIchi + 1
1346 SlplitQuads_8Item = ""
1347 sWk = Split(sQuads, ",")
1348 For i1 = (iIchi * 8 - 8) To iIchi * 8 - 1
1349 If SlplitQuads_8Item <> "" Then _
1350 SlplitQuads_8Item = SlplitQuads_8Item & ","
1351 SlplitQuads_8Item = SlplitQuads_8Item & sWk(i1)
1352 Next i1
1353 End Function
1354
1355 '**************************************************
1356 '
1357 ' 座標のQuads値より表示タイプを調べる
1358 '
1359 ' Create : 2020/06/07
1360 ' Version: 1.0.0
1361 '
1362 ' 備考 : Doubleで比較しないと対象外が出てしまう
1363 '
1364 '**************************************************
1365 Public Function CheckQuadsType( _
1366 ByVal sQuads As String) As Long
1367
1368 Dim ax As Double
1369 Dim ay As Double
1370 Dim bX As Double
1371 Dim bY As Double
1372 Dim cx As Double
1373 Dim cy As Double
1374 Dim dx As Double
1375 Dim dy As Double
1376
1377 If Trim(sQuads) = "" Then
1378 CheckQuadsType = zType.iEtc
1379 ' Stop
1380 Exit Function
1381 End If
1382
1383 Dim sWk() As String
1384 sWk = Split(sQuads, ",")
1385
1386 '▼座標の状態からタイプを出す
1387 ax = Val(sWk(2)) - Val(sWk(0))
1388 ay = Val(sWk(3)) - Val(sWk(1))
1389 bX = Val(sWk(6)) - Val(sWk(4))
1390 bY = Val(sWk(7)) - Val(sWk(5))
1391 cx = Val(sWk(0)) - Val(sWk(4))
1392 cy = Val(sWk(1)) - Val(sWk(5))
1393 dx = Val(sWk(2)) - Val(sWk(6))
1394 dy = Val(sWk(3)) - Val(sWk(7))
1395
1396 Dim i1 As Long
1397
1398 For i1 = 0 To 1
1399
1400 Select Case True
1401 Case (ay = 0 And bY = 0) And _
1402 (ax > 0 And bX > 0 And cy > 0 And dy > 0)
1403 '通常
1404 CheckQuadsType = zType.iNormal
1405 Case (ay = 0 And bY = 0) And _
1406 (ax > 0 And bX > 0 And cy > 0 And dy > 0)
1407 'イタリック
1408 CheckQuadsType = zType.iItalic
1409 Case (ay = 0 And bY = 0) And _
1410 (ax < 0 And bX < 0 And cy < 0 And dy < 0)
1411 '180度回転
1412 CheckQuadsType = zType.i180R
1413 Case (ax > 0 And ay > 0 And bX > 0 And bY > 0) And _
1414 (cy > 0 And dy > 0)
1415 '左向き(1-89)回転
1416 CheckQuadsType = zType.iLeft
1417 Case (ax > 0 And ay < 0 And bX > 0 And bY < 0) And _
1418 (cy > 0 And dy > 0)
1419 '右向き(1-89)回転
1420 CheckQuadsType = zType.iRight
1421 Case (ax < 0 And ay > 0 And bX < 0 And bY > 0) And _
1422 (cy < 0 And dy < 0)
1423 '左向き(91-179)回転
1424 CheckQuadsType = zType.iLeft_2
1425 Case (ax < 0 And ay < 0 And bX < 0 And bY < 0) And _
1426 (cy < 0 And dy < 0)
1427 '右向き(91-179)回転
1428 CheckQuadsType = zType.iRight_2
1429 '※以下はその他の直前（この位置）で判断しないと駄目
1430 Case (ax = 0 And bX = 0) And _
1431 (ay < 0 And bY < 0)
1432 '右90度回転
1433 CheckQuadsType = zType.iRight90R
1434 Case (ax = 0 And bX = 0) And _
1435 (ay > 0 And bY > 0)
1436 '左90度回転
1437 CheckQuadsType = zType.iLeft90R
1438
1439 Case Else
1440 '「その他」として扱う
1441 CheckQuadsType = zType.iEtc
1442 ' Stop
1443 End Select
1444
1445 If CheckQuadsType <> zType.iEtc Then Exit For
1446
1447 '「その他」の場合は誤差を考慮して再チェック
1448 '小数点以下は四捨五入
1449 ax = Val(Format(ax, "0"))
1450 ay = Val(Format(ay, "0"))
1451 bX = Val(Format(bX, "0"))
1452 bY = Val(Format(bY, "0"))
1453 cx = Val(Format(cx, "0"))
1454 cy = Val(Format(cy, "0"))
1455 dx = Val(Format(dx, "0"))
1456 dy = Val(Format(dy, "0"))
1457 Next i1
1458
1459 End Function
1460
1461 ''-----------------------------------------*
1462 '' 【デバッグ用】
1463 '' テスト用のQuads値を生成
1464 ''-----------------------------------------*
1465 'Public Function QQ(ByVal i As Long) As String
1466 ' Dim ii As Long
1467 ' QQ = ""
1468 ' For ii = 1 To i * 8
1469 ' If QQ <> "" Then QQ = QQ & ","
1470 ' QQ = QQ & ii '& ".01"
1471 ' Next ii
1472 'End Function
1473 ''-----------------------------------------*
1474 '' 【デバッグ用】
1475 '' 結果をDebug.Print表示
1476 ''-----------------------------------------*
1477 'Private Sub sOut( _
1478 ' ByRef sTextOut() As String, _
1479 ' ByRef sQuadsOut() As String, _
1480 ' ByVal iAddNo As Long, _
1481 ' iMno() As Long)
1482 ' Dim i1 As Long
1483 ' For i1 = 0 To UBound(sTextOut)
1484 ' Debug.Print "sTou(" & i1 & ")=""" & sTextOut(i1) & """" & _
1485 ' " iMno(" & i1 & ")=" & iMno(i1) & "" & _
1486 ' vbCrLf & "sQou(" & i1 & ")=""" & sQuadsOut(i1) & """"
1487 ' Next i1
1488 ' Debug.Print "iAddNo=" & iAddNo
1489 'End Sub
Highlight：プログラミング言語のソースコードを構文で色分け (GUI編)
1. サンプル：ハイライト表示「Highlight」
検索テキストが複数行（列）にまたがる場合が有りますが、Quads値のおかげで特に意識すること無く処理できます。その使い方にも注目してください。
- 「注釈：ハイライト表示の追加、削除、変更」に使い方の詳細が有ります。
001 Option Explicit
002
003 'Debug Mode True：オン False：オフ
004 Private Const DEBUG_MODE As Boolean = False
005
006 '**************************************************
007 '
008 ' 関数をテストする為の呼び出しルーチン
009 '
010 ' 関数を呼び出し後、結果を確認する為に、
011 ' 座標からPDFに注釈を貼り付ける。
012 '
013 ' Create : 2020/03/25
014 ' Update : 2020/06/09
015 ' Vertion : 1.0.2
016 '
017 '**************************************************
018
019 Sub Test_Main_Highlight()
020
021 Dim start As Double: start = Timer
022
023 Dim i1 As Long
024 Dim bRet As Boolean
025 Dim sPdfFilePath As String
026 Dim iOutCnt As Long
027 Dim gSerch(19) As type_SerchTexts
028 Dim gRects() As type_TextRect
029
030 Const CON_TEST = 3
031
032 Erase gSerch
033 i1 = 0
034 If CON_TEST = 1 Then
035 gSerch(i1).sSerchText = "ATA": i1 = i1 + 1
036 gSerch(i1).sSerchText = "ス63": i1 = i1 + 1
037 gSerch(i1).sSerchText = "Windows": i1 = i1 + 1
038 gSerch(i1).sSerchText = "Home 64": i1 = i1 + 1
039 gSerch(i1).sSerchText = "10": i1 = i1 + 1
040 gSerch(i1).sSerchText = "8GB": i1 = i1 + 1
041 gSerch(i1).sSerchText = "USB": i1 = i1 + 1
042 gSerch(i1).sSerchText = "HDD": i1 = i1 + 1
043 gSerch(i1).sSerchText = "i5-9400": i1 = i1 + 1
044 gSerch(i1).sSerchText = "RAM": i1 = i1 + 1
045 gSerch(i1).sSerchText = "音電": i1 = i1 + 1
046 gSerch(i1).sSerchText = "6ス": i1 = i1 + 1
047 gSerch(i1).sSerchText = "ル)": i1 = i1 + 1
048 gSerch(i1).sSerchText = "Adobe": i1 = i1 + 1
049 gSerch(i1).sSerchText = "Acrobat": i1 = i1 + 1
050 gSerch(i1).sSerchText = "JavaScript": i1 = i1 + 1
051 gSerch(i1).sSerchText = "Get": i1 = i1 + 1
052 gSerch(i1).sSerchText = "getPage": i1 = i1 + 1
053 gSerch(i1).sSerchText = "Common Dialog Control": i1 = i1 + 1
054 gSerch(i1).sSerchText = "Text""annot": i1 = i1 + 1
055 sPdfFilePath = ThisWorkbook.Path & "\test-002.pdf"
056 ElseIf CON_TEST = 2 Then
057 gSerch(i1).sSerchText = "文目": i1 = i1 + 1
058 gSerch(i1).sSerchText = "ビューア": i1 = i1 + 1
059 gSerch(i1).sSerchText = "文字や図形や画像": i1 = i1 + 1
060 gSerch(i1).sSerchText = "Acrobat Reader": i1 = i1 + 1
061 gSerch(i1).sSerchText = "テキスト": i1 = i1 + 1
062 gSerch(i1).sSerchText = "構成する様々な要素": i1 = i1 + 1
063 gSerch(i1).sSerchText = "%PDF-1.2": i1 = i1 + 1 '(1)
064 ' gSerch(i1).sSerchText = "%PDF- 1.2": i1 = i1 + 1 '(2)
065 gSerch(i1).sSerchText = "Acrobat": i1 = i1 + 1
066 gSerch(i1).sSerchText = "がPDF": i1 = i1 + 1
067 gSerch(i1).sSerchText = "<</Type": i1 = i1 + 1 '(1)
068 ' gSerch(i1).sSerchText = "<< /Type": i1 = i1 + 1 '(2)
069 gSerch(i1).sSerchText = "f 000": i1 = i1 + 1 '(2)
070 sPdfFilePath = ThisWorkbook.Path & "\手書きPDF入門-4.pdf"
071 Else
072 gSerch(i1).sSerchText = "Window": i1 = i1 + 1
073 gSerch(i1).sSerchText = "10 Home": i1 = i1 + 1
074 gSerch(i1).sSerchText = "ビット列": i1 = i1 + 1
075 gSerch(i1).sSerchText = "peof": i1 = i1 + 1
076 gSerch(i1).sSerchText = "推奨": i1 = i1 + 1
077 gSerch(i1).sSerchText = "Version !": i1 = i1 + 1
078 gSerch(i1).sSerchText = "& app.form": i1 = i1 + 1
079 gSerch(i1).sSerchText = "= 8": i1 = i1 + 1
080 sPdfFilePath = ThisWorkbook.Path & "\Test-x05.pdf"
081 End If
082
083 bRet = GetTextsGetRects(sPdfFilePath, -1, -1, _
084 gSerch, gRects, iOutCnt)
085 '********************************************
086 '▼ これ以降は結果を確認する為のロジック ▼
087 '********************************************
088
089 'On Error Resume Next
090 Dim sWk As String
091 Dim sWkCon As String
092 Dim i2 As Long
093 Dim sAJS As String
094 Dim sReturn As String
095 Dim objAcroApp As New Acrobat.AcroApp
096 Dim objAcroAVDoc As New Acrobat.AcroAVDoc
097 Dim objAcroPDDoc As New Acrobat.AcroPDDoc
098 Dim objAcroPDPage As Acrobat.AcroPDPage
099 Dim objAcroAVPageView As Acrobat.AcroAVPageView
100 Dim objAFormApp As AFORMAUTLib.AFormApp
101 Dim objAFormFields As AFORMAUTLib.Fields
102
103 objAcroApp.CloseAllDocs
104 objAcroApp.Hide '稀にデスクトップに表示されるので隠す
105 'PDFファイルを開く
106 bRet = objAcroAVDoc.Open(sPdfFilePath, "")
107 Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
108 Set objAFormApp = CreateObject("AFormAut.App")
109 Set objAFormFields = objAFormApp.Fields
110
111 Const sAcrobatJavaScript3 = _
112 "oRet = this.addAnnot({" & _
113 " type:'Highlight' ," & _
114 " quads:[@q] ," & _
115 " page:@p ," & _
116 " strokeColor:@c ," & _
117 "}); "
118 ' " contents:'@t', " & _
119 ' " author:'@A' ," & _
120
121 If DEBUG_MODE Then
122 Call Put_Degug_log("")
123 For i1 = 0 To iOutCnt
124 With gRects(i1)
125 If .sQuads <> "" Then
126 sWk = gSerch(.iSearchNo).sSerchText
127 Call Put_Degug_log( _
128 "Text(" & i1 & ")=[" & sWk & _
129 "] SIndex=" & .iSearchNo & _
130 " Page=" & .iPageNo & _
131 " Quads=" & .sQuads)
132 End If
133 End With
134 Next i1
135 End If
136
137 For i1 = 0 To iOutCnt
138 With gRects(i1)
139 If .sQuads = "" Then GoTo Skip1:
140 sWk = Replace(gSerch(.iSearchNo).sSerchText, "'", "''")
141 sWkCon = "Text=[" & sWk & "] " & _
142 " Quads=" & .sQuads
143 sAJS = sAcrobatJavaScript3
144 sAJS = Replace(sAJS, "@q", EditQuads_8item(.sQuads))
145 sAJS = Replace(sAJS, "@c", "color.yellow")
146 sAJS = Replace(sAJS, "@p", .iPageNo)
147 sAJS = Replace(sAJS, "@t", sWkCon)
148 End With
149 '■Acrobat JavaScript の実行
150 sReturn = objAFormFields.ExecuteThisJavascript(sAJS)
151 Skip1:
152 Next i1
153
154 'PDFファイルを別名で保存
155 Dim sFilePathOut As String
156 sFilePathOut = Replace(sPdfFilePath, ".pdf", "-Highlight.pdf")
157 If objAcroPDDoc.Save(1, sFilePathOut) = False Then
158 MsgBox "PDFファイルへ保存出来ませんでした", _
159 vbOKOnly + vbCritical, "実行エラー"
160 End If
161 '変更しないで閉じます。
162 bRet = objAcroAVDoc.Close(False)
163 'Acrobatアプリケーションの終了
164 objAcroApp.Hide
165 objAcroApp.Exit
166 'オブジェクトの開放
167 Set objAcroAVPageView = Nothing
168 Set objAcroPDPage = Nothing
169 Set objAcroAVDoc = Nothing
170 Set objAFormApp = Nothing
171 Set objAFormFields = Nothing
172 Set objAcroApp = Nothing
173
174 Debug.Print "出力件数 = " & iOutCnt
175 Debug.Print "処理時間 = " & Timer - start
176
177 If DEBUG_MODE Then Call Run_NOTEPAD
178 End Sub
179
180 '**************************************************
181 '
182 ' Quads値を８値で１組に変換する
183 '
184 ' Create : 2020/06/08
185 ' Version: 1.0.0
186 '
187 ' 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 ->
188 ' [1,2,3,4,5,6,7,8],[9,10,11,12,13,14,15]
189 '
190 '**************************************************
191 'Sub Test_EditQuads_8item()
192 ' Debug.Print EditQuads_8item(QQ(3))
193 '' [1,2,3,4,5,6,7,8]
194 '' [1,2,3,4,5,6,7,8] , [9,10,11,12,13,14,15,16]
195 'End Sub
196 Private Function EditQuads_8item(ByVal sQuads As String)
197 Dim sWk() As String
198 Dim sQ As String
199 Dim i1 As Long
200 EditQuads_8item = ""
201 sWk = Split(sQuads, ",")
202 For i1 = 0 To UBound(sWk) Step 8
203 sQ = "[" & sWk(i1 + 0) & ","
204 sQ = sQ + sWk(i1 + 1) & ","
205 sQ = sQ + sWk(i1 + 2) & ","
206 sQ = sQ + sWk(i1 + 3) & ","
207 sQ = sQ + sWk(i1 + 4) & ","
208 sQ = sQ + sWk(i1 + 5) & ","
209 sQ = sQ + sWk(i1 + 6) & ","
210 sQ = sQ + sWk(i1 + 7) & "]"
211 If EditQuads_8item <> "" Then _
212 EditQuads_8item = EditQuads_8item & ","
213 EditQuads_8item = EditQuads_8item & sQ
214 Next i1
215 End Function
Highlight：プログラミング言語のソースコードを構文で色分け (GUI編)
上記の実行結果です。
2. サンプル：多角形の注釈「Polygon」
注釈のテキスト部分には座標の内容を入れました。
多角形の注釈については後日、少し詳しく書いた使い方のサンプルを別ページに追加予定です。
001 Option Explicit
002
003 'Debug Mode True：オン False：オフ
004 Private Const DEBUG_MODE As Boolean = False
005
006 '**************************************************
007 '
008 ' 関数をテストする為の呼び出しルーチン
009 '
010 ' 関数を呼び出し後、結果を確認する為に、
011 ' 座標からPDFに注釈を貼り付ける。
012 '
013 ' Create : 2020/03/25
014 ' Update : 2020/06/11
015 ' Vertion : 1.0.2
016 '
017 '**************************************************
018
019 Sub Test_Main_Square()
020
021 Dim start As Double: start = Timer
022
023 Dim i1 As Long
024 Dim bRet As Boolean
025 Dim sPdfFilePath As String
026 Dim iOutCnt As Long
027 Dim gSerch(19) As type_SerchTexts
028 Dim gRects() As type_TextRect
029
030 Const CON_TEST = 3
031
032 Erase gSerch
033 i1 = 0
034 If CON_TEST = 1 Then
035 gSerch(i1).sSerchText = "ATA": i1 = i1 + 1
036 gSerch(i1).sSerchText = "ス63": i1 = i1 + 1
037 gSerch(i1).sSerchText = "Windows": i1 = i1 + 1
038 gSerch(i1).sSerchText = "Home 64": i1 = i1 + 1
039 gSerch(i1).sSerchText = "10": i1 = i1 + 1
040 gSerch(i1).sSerchText = "8GB": i1 = i1 + 1
041 gSerch(i1).sSerchText = "USB": i1 = i1 + 1
042 gSerch(i1).sSerchText = "HDD": i1 = i1 + 1
043 gSerch(i1).sSerchText = "i5-9400": i1 = i1 + 1
044 gSerch(i1).sSerchText = "RAM": i1 = i1 + 1
045 gSerch(i1).sSerchText = "音電": i1 = i1 + 1
046 gSerch(i1).sSerchText = "6ス": i1 = i1 + 1
047 gSerch(i1).sSerchText = "ル)": i1 = i1 + 1
048 gSerch(i1).sSerchText = "Adobe": i1 = i1 + 1
049 gSerch(i1).sSerchText = "Acrobat": i1 = i1 + 1
050 gSerch(i1).sSerchText = "JavaScript": i1 = i1 + 1
051 gSerch(i1).sSerchText = "Get": i1 = i1 + 1
052 gSerch(i1).sSerchText = "getPage": i1 = i1 + 1
053 gSerch(i1).sSerchText = "Common Dialog Control": i1 = i1 + 1
054 gSerch(i1).sSerchText = "Text""annot": i1 = i1 + 1
055 sPdfFilePath = ThisWorkbook.Path & "\test-002.pdf"
056 ElseIf CON_TEST = 2 Then
057 gSerch(i1).sSerchText = "文目": i1 = i1 + 1
058 gSerch(i1).sSerchText = "ビューア": i1 = i1 + 1
059 gSerch(i1).sSerchText = "文字や図形や画像": i1 = i1 + 1
060 gSerch(i1).sSerchText = "Acrobat Reader": i1 = i1 + 1
061 gSerch(i1).sSerchText = "テキスト": i1 = i1 + 1
062 gSerch(i1).sSerchText = "構成する様々な要素": i1 = i1 + 1
063 gSerch(i1).sSerchText = "%PDF-1.2": i1 = i1 + 1
064 gSerch(i1).sSerchText = "Acrobat": i1 = i1 + 1
065 gSerch(i1).sSerchText = "がPDF": i1 = i1 + 1
066 gSerch(i1).sSerchText = "<</Type": i1 = i1 + 1 'VBAの検索
067 'gSerch(i1).sSerchText = "<< /Type": i1 = i1 + 1 '手での検索
068 sPdfFilePath = ThisWorkbook.Path & "\手書きPDF入門-4.pdf"
069 Else
070 gSerch(i1).sSerchText = "Window": i1 = i1 + 1
071 gSerch(i1).sSerchText = "10 Home": i1 = i1 + 1
072 gSerch(i1).sSerchText = "ビット列": i1 = i1 + 1
073 gSerch(i1).sSerchText = "peof": i1 = i1 + 1
074 gSerch(i1).sSerchText = "推奨": i1 = i1 + 1
075 gSerch(i1).sSerchText = "Version !": i1 = i1 + 1
076 gSerch(i1).sSerchText = "& app.form": i1 = i1 + 1
077 gSerch(i1).sSerchText = "= 8": i1 = i1 + 1
078 sPdfFilePath = ThisWorkbook.Path & "\Test-x05.pdf"
079
080 End If
081
082 bRet = GetTextsGetRects(sPdfFilePath, -1, -1, _
083 gSerch, gRects, iOutCnt)
084
085 '********************************************
086 '▼ これ以降は結果を確認する為のロジック ▼
087 '********************************************
088
089 On Error Resume Next
090 Dim sWk As String
091 Dim sWkCon As String
092 Dim i2 As Long
093 Dim sAJS As String
094 Dim sReturn As String
095 Dim objAcroApp As New Acrobat.AcroApp
096 Dim objAcroAVDoc As New Acrobat.AcroAVDoc
097 Dim objAcroPDDoc As New Acrobat.AcroPDDoc
098 Dim objAcroPDPage As Acrobat.AcroPDPage
099 Dim objAcroAVPageView As Acrobat.AcroAVPageView
100 Dim objAFormApp As AFORMAUTLib.AFormApp
101 Dim objAFormFields As AFORMAUTLib.Fields
102
103 objAcroApp.CloseAllDocs
104 objAcroApp.Hide '稀にデスクトップに表示されるので隠す
105 'PDFファイルを開く
106 bRet = objAcroAVDoc.Open(sPdfFilePath, "")
107 Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
108 Set objAFormApp = CreateObject("AFormAut.App")
109 Set objAFormFields = objAFormApp.Fields
110
111 '多角形 Acrobat JavaScript
112 Const sAcrobatJavaScript = _
113 "var annot=this.addAnnot({" & _
114 " page: @p," & _
115 " type: 'Polygon'," & _
116 " vertices: @v," & _
117 " strokeColor: @c," & _
118 " width: 0.1," & _
119 " contents: '@t' ," & _
120 "});"
121
122 If DEBUG_MODE Then
123 Call Put_Degug_log("")
124 For i1 = 0 To iOutCnt
125 With gRects(i1)
126 If .iSearchNo = -1 Then Exit For
127 sWk = gSerch(.iSearchNo).sSerchText
128 Call Put_Degug_log( _
129 "Text(" & i1 & ")=[" & sWk & _
130 "] SIndex=" & .iSearchNo & _
131 " Page=" & .iPageNo & _
132 " Quads=" & .sQuads)
133 End With
134 Next i1
135 End If
136
137 Dim sWk1() As String
138 Dim sVertices() As String
139
140 For i1 = 0 To iOutCnt
141 With gRects(i1)
142 If .iSearchNo = -1 Then Exit For
143 If .sQuads <> "" Then
144 sWk = Replace(gSerch(.iSearchNo).sSerchText, "'", "''")
145 sWkCon = "Text=[" & sWk & "] " & _
146 " Quads=" & .sQuads
147
148 Call ConvertToVertices(.sQuads, sVertices)
149 For i2 = 0 To UBound(sVertices)
150 sAJS = sAcrobatJavaScript
151 sAJS = Replace(sAJS, "@p", .iPageNo)
152 sAJS = Replace(sAJS, "@v", sVertices(i2))
153 sAJS = Replace(sAJS, "@c", "color.blue")
154 sAJS = Replace(sAJS, "@t", gSerch(.iSearchNo).sSerchText)
155 sReturn = objAFormFields.ExecuteThisJavascript(sAJS)
156 Next i2
157 End If
158 End With
159 Next i1
160
161 'PDFファイルを別名で保存
162 Dim sFilePathOut As String
163 sFilePathOut = Replace(sPdfFilePath, ".pdf", "-Square.pdf")
164 If objAcroPDDoc.Save(1, sFilePathOut) = False Then
165 MsgBox "PDFファイルへ保存出来ませんでした", _
166 vbOKOnly + vbCritical, "実行エラー"
167 End If
168 '変更しないで閉じます。
169 bRet = objAcroAVDoc.Close(False)
170 'Acrobatアプリケーションの終了
171 objAcroApp.Hide
172 objAcroApp.Exit
173 'オブジェクトの開放
174 Set objAcroAVPageView = Nothing
175 Set objAcroPDPage = Nothing
176 Set objAcroAVDoc = Nothing
177 Set objAFormApp = Nothing
178 Set objAFormFields = Nothing
179 Set objAcroApp = Nothing
180
181 Debug.Print "出力件数 = " & iOutCnt
182 Debug.Print "処理時間 = " & Timer - start
183
184 If DEBUG_MODE Then Call Run_NOTEPAD
185 End Sub
186
187 '**************************************************
188 '
189 ' 文字列のQuads値を2座標単位で分割して返す関数
190 '
191 ' sQuads：Quads値が入った文字列
192 ' sVertices：Verticesプロパティに渡す形式の座標
193 '
194 ' Create : 2020/06/07
195 '**************************************************
196 Public Sub ConvertToVertices( _
197 ByVal sQuads As String, _
198 ByRef sVertices() As String)
199
200 Dim sWk() As String
201 Dim sItem2 As String
202 Dim i1 As Long
203 Dim i2 As Long
204
205 sWk = Split(sQuads, ",")
206 ReDim sVertices((UBound(sWk) + 1) / 8 - 1) As String
207 i2 = -1
208 For i1 = 0 To UBound(sWk) Step 8
209 i2 = i2 + 1
210 sVertices(i2) = "[[" & _
211 sWk(i1 + 0) & "," & sWk(i1 + 1) & "],[" & _
212 sWk(i1 + 2) & "," & sWk(i1 + 3) & "],[" & _
213 sWk(i1 + 6) & "," & sWk(i1 + 7) & "],[" & _
214 sWk(i1 + 4) & "," & sWk(i1 + 5) & "]]"
215 Next i1
216 End Sub
Highlight：プログラミング言語のソースコードを構文で色分け (GUI編)
上記の実行結果です。
全角テキストの検索
特に問題なく検索可能です。改行は１つの半角空白を入れるだけです。
半角テキストの検索
連続する半角テキストは特に注意することは有りません。
例：「Acrobat」、「PDF」
空白で分れている複数のテキスト（単語）を検索する時は、同じ様に空白を入れて検索します。
例：「Adobe Acrobat」、「Acrobat JavaScript」
改行したテキストの場合は、改行箇所に半角の空白を入れて検索します。
例：「表示します。 本体と」
但し、見た目での改行と実際の改行は、なかなか判断出来ません。以下の場合、「%PDF-1.2」は見た目では改行していますが、実際は連続したテキストです。「表示します。」の後は改行しています。
また、以下も御覧ください。半角テキストの「<<」と「/Type」は行が違います。
Acrobat Reader上でテキスト検索すると
- 「<</Type」 ：NG
- 「<< /Type」：OK
しかし、次の場合をAcrobat Readerで検索すると
- 「%PDF-1.2」 ：OK
- 「%PDF- 1.2」：OK
当関数では上記２つの場合の検索方法を統一しています。
- 「<</Type」 ：OK
- 「<< /Type」：NG
- 「PDF-1.2」 ：OK
- 「PDF- 1.2」：NG
この方が自然と考えたからです。
当関数では「改行時の最後の文字が半角記号の場合はスペース無し」で検索する処理方法にしています。賛否は有ると思いますが、今はこの考え方で公開する事にしました。
英単語が２行にまたがる時
※上記の「%PDF-1.2」とは異なる話です。
長い英単語は時として、テキスト途中にハイフン「-」を追加して２行にまたがらせるときが有ります。
上記はAcrobat Readerでテキスト「outof」を検索した時です。画面上は「out-of」と改行場所にハイフンが挿入されます。英文文書ではよく見られることです。当然、「out-of」での検索はNGになります。
当関数も上記の場合と同様に「outof」で検索できます。「out-of」も同様にNGです。但し、検索結果は「out」と「of」の２つのQuads座標を返します。
例：11,22,33,44,55,66,77,88,99,00,11,22,33,44,55,66 の16個の値
座標の値が正確に出ない場合
Acrobat OLE も Acrobat JavaScript も以下の単位でテキストの座標を基本的に返します。（但し、例外も多数有り）
- 半角 ：
空白、記号、改行等を区切りにした文字列のテキスト
※メーカー公開マニュアルではこれを単語と言います。 - 全角 ：
１文字（１テキスト）単位
以下を見てください。当関数を使ってテキスト「Acrobat」で検索し、その座標に青線の長方形の注釈を付けました。しかし「Acrobat」の最後の「t」が外側にあります。
当関数では
- 「Acrobat！」を１つの単語として座標を取得
※取得テキストの長さ、座標の取得方法の変更は出来ません。 - うしろの「！」は不要なので、文字数で座標を再計算
- しかし各文字の幅が異なるために、文字数で座標の再計算をすると「t」の横幅が小さいために外に出てしまいます。
１文字の幅が同じ等幅フォントの場合は再計算で正確な位置が出せます。しかし、プロポーショナルフォント (または可変幅フォント)では文字毎に文字幅が異なります。
フォントを意識した計算ロジックを追加するするのは、現実的に（今は）無理です。
それは困る！と言う方は、座標に１ポイント程度のマージンを追加してみてください。
注意：改行箇所にハイフンが有る単語はハイフン無しで検索できる、とは限りません。例外も多少有りました。よって、実際は何が正しいかは分かってないのが現状です。
参照
備考
- 関数内部にはデバッグ用のロジックも一部残してあります。
- 開発時の精度を上げるためにサブルーチンを多用しました。
- Quads値の使い方はサンプルを御覧ください。
管理者の技術メモ
これ以降はサイト管理者が当ページを管理するための技術メモです。よって、見なくても結構です。
抽出単語の区切り
半角の抽出単語の最後の空白１文字を区切りに使う。但し、改行、LF、CRによっては話が変わる。全角（日本語）に空白と言う区切りは無い。この件は長くなるので、詳細は別ページでまとめる。
単語（テキスト）抽出方法の変更
- バージョン１.0：Acrobat OLE
- バージョン２.0：Acrobat JavaScript＋Quads座標 -> Rect座標に変換
- バージョン３.0：Acrobat JavaScript＋Quads座標
Acrobat OLEは致命的なバグが有り使えない。Rect座標を基本とするやり方は知識不足から招いた間違い。PDFのテキスト座標にはまだ分からないことも有る（が）。結果、Quads値の形式を基本とする使い方が正しいと判断した。ココまで来るのに３ヶ月以上も掛かった。（恥
Acrobat JavaScriptの使用
当初はAcrobat OLEの GetText ＋ GetRect を使っていたが、以下の理由でAcrobat JavaScriptの使用に変更した。
- 抽出されない文字（記号類）が有る
- 処理時間が非常に掛かる
- ロジックがやや複雑になる
１は致命的で回避できなかった。調べるだけ時間の無駄！
更にAcrobat JavaScriptの方がAcrobat OLEのGetRectより、正確な座標が得られる。以下は座標 Top 数値の例。
- Acrobat OLE の GetRect ：842
- Acrobat JavaScript の quads：841.607421875
Acrobat JavaScriptでは小数点以下の値も得られる。小さい文字の場合、たった１ポイントの差がはみ出した位置になってしまう場合も有る（有った）。これもAcrobat OLEを使わない理由。
Acrobat JavaScriptメモ
thisは付けない
Acrobat JavaScriptには頭に「this.」を付ける場合が有る。公開マニュアル中のサンプルにも書かれている。今回のテキスト抽出のサンプルもそれに従ったが、不具合が出た。図中のテキストが連続して一括で抽出されるケースが多発した。「this.」は無くてもAcrobat JavaScriptは動作する。但し、DCでは付けても正常。XIのみの現象と思われる。それ以外のバージョンは未確認。
type: "Highlight"「ハイライト」
座標にはquadsプロパティしか使えない。rectを使うと指定の座標には作成されない。メーカー公式マニュアル、更にネット情報を見るとすべてrectプロパティを使っているが、サンプルをコピペして実行しても結果は不良となる。
type: "Polygon"「多角形の注釈」
座標指定はverticesプロパティを使う。QuadsやRectは使えない。指定順序に沿って線が引かれる。最初の位置と最後の位置が最終的に結びの線となる。
例：vertices: [ [1x , 1y ] , [2x , 2y ] ,[3x , 3y ] ,[4x , 4y ] ]
type: "Square"「長方形の注釈」
座標指定にquadsプロパティは使えない。実行してもエラーにはならないが、注釈が作成されなかった。座標はrectプロパティを使う。
Quadsプロパティと場所が変わることに注意が必要。
同一行の判断機能は無し
当関数のバージョン2.0以前は「テキストが同じ行（列）かの判断はTopとBottomの差が共に0.9より下の場合とする」と有りましたが、現バージョン3.0以降は判断する機能は無くなりました。内部の処理方法が大きく変わった為です。
001 If Abs(iWkZahyo(i4, Zahyo.iTop) - _
002 iWkZahyo(i4 + 1, Zahyo.iTop)) < 0.9 And _
003 Abs(iWkZahyo(i4, Zahyo.iBottom) - _
004 iWkZahyo(i4 + 1, Zahyo.iBottom)) < 0.9 Then
005 '次は同じ行
半角テキストの検索
以下を御覧ください。半角テキストの「<<」と「/Type」は行が違います。
Acrobat Reader上でテキスト検索すると
- 「<</Type」 ：NG
- 「<< /Type」：OK
しかし、次の場合で検索すると
- 「PDF-1.2」 ：OK
- 「PDF- 1.2」：OK
当関数では上記２つの場合の検索方法を統一しています。
- 「<</Type」 ：OK
- 「<< /Type」：NG
- 「PDF-1.2」 ：OK
- 「PDF- 1.2」：NG
この方が自然と考えたからです。
関数内部では「改行時の最後の文字が半角記号の場合はスペース無し」で検索する処理方法にしています。賛否は有ると思いますが、今はこの考え方で公開する事にしました。
以上。