関数:文字列のページ番号と座標を返す

TOP > サンプル/関数 > *      [...]

Tradition in Kyoto

概要

PDFページ上のテキストを検索し、以下の位置情報を返します。

  • ページ番号
  • 座標(四隅の各位置)

これが有れば、テキストへのハイライト表示、取り消し線、下線、リンク、注釈等の追加が可能になります。

リンク
PDFのテキスト座標がわかれば、こんな事も出来る

当関数はAcrobat OLE経由でAcrobat JavaScriptを実行し、PDF上のテキストの座標を取得します。

 

座標はQuads値

座標はAcrobat JavaScriptのQuadsプロパティの形式で返します。8つの値を一組でテキストの四方座標を示します。

各値はカンマ区切りです。例えば、↓ こんな感じです。

[ 1x , 1y , 2x , 2y , 3x , 3y , 4x , 4y ] = [ 91.58000183105469 , 621.9847412109375 , 119.71980285644531 , 621.9847412109375 , 91.58000183105469 , 614.0368041992188 , 119.71980285644531 , 614.0368041992188 ]

小数点以下は不要にも思えますが、当関数では何も加工せずに返しています。

機能

  1. 指定したPDFページのテキストを検索します。
  2. 検索テキストは半角文字、全角文字(日本語)、混在の文字、複数の単語が含まれた文字列(途中に半角の空白)でも構いません。
  3. 一致したテキストの座標(Quadsプロパティの値)を返します。座標はページ左下を基点( 0, 0 )とします。
  4. 検索テキストが複数行(列)にまたがる場合は複数の座標を返します。
  5. 検索ページの範囲を簡易ですが指定できます。

 

制限

  1. ページにまたがるテキストは検索できません。
  2. 半角英字は大文字小文字を区別します。
    理由:区別無しは処理が複雑になる為
    対処:区別無しにしたい場合は、大文字有り、大文字無しを検索文字に追加して下さい。
  3. テキスト中に改行コード、タブ等の制御コードは使えません。使うと検索できません。

 

注意事項

  1. PDF上に表示されているテキストの座標を正確に返せない場合が有ります。原因はAcrobat側がテキストと一対一の座標を返さないからです。以下の場合は注意です。
    • 表紙、裏表紙
    • 目次、索引、表、一覧等のリスト形式の書式
    • 数式や図中のテキスト ※ほぼ100%に近い
  2. 上記問題は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です。他は関数側で返します。

  1. 第一引数(sPdfFilePath):検索するPDFのフルパス
  2. 第二引数(iPageStartIn):検索の開始ページ
    先頭ページは1です。
    -1 を入れると先頭ページから検索します。
  3. 第三引数(iPageEndIn): 検索の終了ページ
    -1 を入れると最終ページまで検索します。
  4. 第四引数(gSerch(n) As typeSerchTexts):
  5. 第五引数(gRects(x) As typeTextRect):検索した結果
    • iPageNo As Long :ページ番号
    • iSearchNo As Long:sSerchTextの配列番号のn
    • sQuads As String:Quadsプロパティの座標値
      全てカンマ区切りです。8個単位で一組。
  6. 第六引数(iOutCnt): gRects(x) の x 値
    検索した合計数。

typeSerchTexts と typeTextRect はユーザー定義形のType変数です。使い方はサンプルを御覧ください。

 

戻り値

  1. True : 正常
  2. False : エラー。第一引数のファイルがPDFで無い等。

 

動作検証した環境

  • Windows 10 64bit Pro
  • Adobe Acrobat XI Pro (バージョン 11.0.23)
  • MS Office - Excel 2007 - VBA

 

 

関数のソース - VBA

以下のダウンロードファイルには当関数を使う上で必要な他の関数やサブルーチン、当関数をつかったサンプルロジック(ハイライト表示、多角形の注釈の作成)が入っています。

ダウンロード:sample-GetTextsGetRects.xls

参照設定が2つ必要です。

当関数を使ったサンプルも2つ入れています。当ページの後半に紹介しています。

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:最後に空白1つ有り 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 '180度回転 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 ' 引数1 : sPdfFilePath As String (IN) 113 ' 検索するPDFのフルパス 114 ' 引数2 :iPageStartIn As Long (IN) 115 ' 検索の開始ページ 116 ' 先頭ページは1 117 ' -1は最初から検索 118 ' 引数3 :iPageEndIn As Long (IN) 119 ' 検索の終了ページ 120 ' -1で最終ページまで検索 121 ' 引数4 :gSerch(n) As type_SerchTexts 122 ' sSerchText As String:検索する文字列を指定 (IN) 123 ' iCnt As Long:文字列の検索で一致した件数 (OUT) 124 ' 引数5 :gRects(x) As type_TextRect (OUT) 125 ' 検索した結果 126 ' iPageNo As Long:ページ番号 127 ' iSearchNo As Long:sSerchTextの配列番号のn 128 ' sQuads As String:座標(Quads値) 129 ' 全てカンマ区切り。8個単位で一組。 130 ' 引数6 :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 '▼1文字単位に座標を分割 323 iOut2 = -1 324 For i1 = 0 To iOut1 325 With sJ1_Rt(i1) 326 If Len(.sText) = 1 And .iQuadsCnt = 7 Then 327 '▽1文字+1組Quads値はそのまま使う 328 ReDim sTou(0) As String 329 ReDim sQou(0) As String 330 ReDim iMno(0) As Long 331 sTou(0) = .sText '1文字 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 '▽検索用テキストと1対1の座標配列の「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 '2つの座標をマージする 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値の後8座標の2x,2y,4x,4y と 669 ' 後 のQuads値の前8座標の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 ' 2つの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値の後8座標の2x,2y,4x,4y を 726 '  後のQuads値の前8座標の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 '  1文字テキスト単位での終了状態を判断する時の 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値の数が7以下 828 Stop 'プログラムエラー 829 Exit Sub 830 End If 831 If (UBound(sQin) + 1) / 8 <> _ 832 Int((UBound(sQin) + 1) / 8) Then 833 'Quads値の数が8の倍数で無い 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 '1文字単位で文字コードを取得 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 '1文字単位に分割 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 '1文字の文字コードを取得 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 '1文字が1Quads値 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 ' ハイフンの1文字分の座標を削除する。 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 '配列が8の倍数 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 ' テキストを1文字単位で分割し、 1213 ' Quads値を計算で出す。 1214 ' 1215 ' 1)テキストが2文字以上:例「ABC」 1216 ' 2)Quads数=8 :例「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 '配列が8の倍数 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値を8座標単位で分割して返す関数 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値を8値で1組に変換する 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編)
 

上記の実行結果です。

 

全角テキストの検索

特に問題なく検索可能です。改行は1つの半角空白を入れるだけです。

半角テキストの検索

連続する半角テキストは特に注意することは有りません。

例:「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

当関数では上記2つの場合の検索方法を統一しています。

  • 「<</Type」 :OK
  • 「<< /Type」:NG
  • 「PDF-1.2」 :OK
  • 「PDF- 1.2」:NG

この方が自然と考えたからです。

当関数では「改行時の最後の文字が半角記号の場合はスペース無し」で検索する処理方法にしています。賛否は有ると思いますが、今はこの考え方で公開する事にしました。

英単語が2行にまたがる時

※上記の「%PDF-1.2」とは異なる話です。

長い英単語は時として、テキスト途中にハイフン「-」を追加して2行にまたがらせるときが有ります。

上記はAcrobat Readerでテキスト「outof」を検索した時です。画面上は「out-of」と改行場所にハイフンが挿入されます。英文文書ではよく見られることです。当然、「out-of」での検索はNGになります。

当関数も上記の場合と同様に「outof」で検索できます。「out-of」も同様にNGです。但し、検索結果は「out」と「of」の2つのQuads座標を返します。

例:11,22,33,44,55,66,77,88,99,00,11,22,33,44,55,66 の16個の値

 

座標の値が正確に出ない場合

Acrobat OLE も Acrobat JavaScript も以下の単位でテキストの座標を基本的に返します。(但し、例外も多数有り)

  • 半角 :
    空白、記号、改行等を区切りにした文字列のテキスト
    ※メーカー公開マニュアルではこれを単語と言います。
  • 全角 :
    1文字(1テキスト)単位

以下を見てください。当関数を使ってテキスト「Acrobat」で検索し、その座標に青線の長方形の注釈を付けました。しかし「Acrobat」の最後の「t」が外側にあります。

当関数では

  1. 「Acrobat」を1つの単語として座標を取得
    ※取得テキストの長さ、座標の取得方法の変更は出来ません。
  2. うしろの「」は不要なので、文字数で座標を再計算
  3. しかし各文字の幅が異なるために、文字数で座標の再計算をすると「t」の横幅が小さいために外に出てしまいます。

1文字の幅が同じ等幅フォントの場合は再計算で正確な位置が出せます。しかし、プロポーショナルフォント (または可変幅フォント)では文字毎に文字幅が異なります。

フォントを意識した計算ロジックを追加するするのは、現実的に(今は)無理です。

それは困る!と言う方は、座標に1ポイント程度のマージンを追加してみてください。

注意:改行箇所にハイフンが有る単語はハイフン無しで検索できる、とは限りません。例外も多少有りました。よって、実際は何が正しいかは分かってないのが現状です。

 

参照

 

備考

  • 関数内部にはデバッグ用のロジックも一部残してあります。
  • 開発時の精度を上げるためにサブルーチンを多用しました。
  • Quads値の使い方はサンプルを御覧ください。

 

 


 

管理者の技術メモ

これ以降はサイト管理者が当ページを管理するための技術メモです。よって、見なくても結構です。

抽出単語の区切り

半角の抽出単語の最後の空白1文字を区切りに使う。但し、改行、LF、CRによっては話が変わる。全角(日本語)に空白と言う区切りは無い。この件は長くなるので、詳細は別ページでまとめる。

単語(テキスト)抽出方法の変更

  1. バージョン1.0:Acrobat OLE
  2. バージョン2.0:Acrobat JavaScript+Quads座標 -> Rect座標に変換
  3. バージョン3.0:Acrobat JavaScript+Quads座標

Acrobat OLEは致命的なバグが有り使えない。Rect座標を基本とするやり方は知識不足から招いた間違い。PDFのテキスト座標にはまだ分からないことも有る(が)。結果、Quads値の形式を基本とする使い方が正しいと判断した。ココまで来るのに3ヶ月以上も掛かった。(恥

Acrobat JavaScriptの使用

当初はAcrobat OLEの GetText + GetRect を使っていたが、以下の理由でAcrobat JavaScriptの使用に変更した。

  1. 抽出されない文字(記号類)が有る
  2. 処理時間が非常に掛かる
  3. ロジックがやや複雑になる

1は致命的で回避できなかった。調べるだけ時間の無駄!

更にAcrobat JavaScriptの方がAcrobat OLEのGetRectより、正確な座標が得られる。以下は座標 Top 数値の例。

  • Acrobat OLE の GetRect  :842
  • Acrobat JavaScript の quads:841.607421875

Acrobat JavaScriptでは小数点以下の値も得られる。小さい文字の場合、たった1ポイントの差がはみ出した位置になってしまう場合も有る(有った)。これも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

当関数では上記2つの場合の検索方法を統一しています。

  • 「<</Type」 :OK
  • 「<< /Type」:NG
  • 「PDF-1.2」 :OK
  • 「PDF- 1.2」:NG

この方が自然と考えたからです。

関数内部では「改行時の最後の文字が半角記号の場合はスペース無し」で検索する処理方法にしています。賛否は有ると思いますが、今はこの考え方で公開する事にしました。

以上。

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

CAPTCHA


出来るだけ早く返答する様には心がけています。
が、遅くなる時もありますのでご了承ください。


SAMURAI Plugin

コメントをする時は出来れば以下もお願いします。

  • OS名 バージョン
  • Acrobat バージョン
  • ツール(Excel等) バージョン
コメントにサンプルコードを入れるとエラーになる場合が有ります。その時はコードの前後に <code> ・・・</code> タグを入れてください。

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください