機能
PDF内をテキスト検索して「墨消し（Redact）」にします。墨消しにしたテキストは削除されます。削除されたテキストの復元は出来ません。
Acrobat ９～
Acrobat 9 Pro以上から使用できる機能です。Standard、Readerでは出来ません。
applyRedactionsのセキュリティ権限
墨消しはAcrobat JavaScript「applyRedactions」の実行が必要です。しかしセキュリティ権限が高く、Acrobat OLEでは扱えなくて実行エラーになります。そこで間に別の操作を入れて、その先で権限を高くし、Acrobat OLEからも扱える様にします。以下は手順の概要です。
- Acrobat OLEでAcrobatに追加したメニューを実行：App.MenuItemExecute
- そのメニューで指定したAcrobat JavaScript実行
- そのAcrobat JavaScript内でセキュリティ権限の昇格を行った状態でapplyRedactions を実行（墨消し）
Acrobat 本体にメニューの追加
「redactMenu3.js」Acrobat JavaScriptファイルをAcrobat Proインストール先の以下のフォルダに入れます。手作業です。この js ファイルはこの後のダウンロードファイルに入っています。Acrobatのバージョンにより「11.0」の部分が変わります。
"C:\Program Files (x86)\Adobe\Acrobat 11.0\Acrobat\Javascripts\"
Acrobatアプリケーションを再起動すると「redactMenu3.js」を読み込んでメニューの編集に「GoGoBlack」を追加します。
呼び出し方
Call Edit_Redact(・・・)で呼び出します。
001 Dim i As Long
002 Dim sPDF(2) As String 'IN :PDFファイルのフルパス
003 Dim sText(6) As String 'IN :検索テキスト
004 Dim iCount(2) As Long 'OUT:処理件数
005
006 '処理するPDFファイル
007 sPDF(0) = "D:\work\test01.pdf"
008 sPDF(1) = "D:\work\test02.pdf"
009 sPDF(2) = "D:\work\test03.pdf"
010 '墨消し対象のテキスト
011 sText(0) = "情報"
012 sText(1) = "SDK"
013 sText(2) = "Acrobat"
014 sText(3) = "印刷"
015 sText(4) = "プロジェクト"
016 sText(5) = "安全"
017 sText(6) = "表示"
018
019 Call Edit_Redact(sPDF, sText, iCount)
引数
- 第１引数：IN
PDFファイルのフルパス。配列で渡す。 - 第２引数：IN
墨消し対象のテキスト。配列で渡す。 - 第３引数：OUT
墨消しにした件数を配列で返してくる。第１引数のPDFファイルの配列の添字に合わせる。
１件でも配列で渡します。
サンプル
- 複数のPDFファイルを一括で墨消しします
- 墨消しするテキストは複数指定できます
- 結果は処理するPDFファイル名の後に件数を追加して別名で保存します。
- 事前に「redactMenu3.js」の手作業でのインストールが必要
参照設定：
Download：
/p1217_Annot-Redact.zip ( 81.8 KB )
Excel VBA：
001 Option Explicit
002
003 Private msMsg As String 'メッセージ
004 ' VBA RunTime Error 対応用
005 'Private miErrorNo As Long 'Err.Number の内容
006 'Private msErrorMsg As String 'Err.Description の内容
007
008 '**************************************************
009 '* ココからスタート
010 '**************************************************
011 Sub Main()
012 Debug.Print "Start Time = " & Format(Time, "hh:mm:ss")
013
014 '▼メモリ上のAcrobatプロセスを確認する
015 If iCheckAcrobat() > 0 Then
016 msMsg = "Acrobatが動いています。" _
017 & vbCrLf & "処理を中断します。" & vbCrLf _
018 & vbCrLf & "この後でAcrobatの終了を試みます。"
019 MsgBox msMsg, vbCritical, "実行の中断"
020 'Acrobat OLEの終了を試みる
021 Call EndAcrobat
022 Exit Sub
023 End If
024
025 Dim i As Long
026 Dim sPDF(2) As String 'IN :PDFファイルのフルパス
027 Dim sText(6) As String 'IN :検索テキスト
028 Dim iCount(2) As Long 'OUT:処理件数
029
030 '処理するPDFファイル
031 sPDF(0) = "D:\work\test01.pdf"
032 sPDF(1) = "D:\work\test02.pdf"
033 sPDF(2) = "D:\work\test03.pdf"
034 '墨消し対象のテキスト
035 sText(0) = "情報"
036 sText(1) = "SDK"
037 sText(2) = "Acrobat"
038 sText(3) = "印刷"
039 sText(4) = "プロジェクト"
040 sText(5) = "安全"
041 sText(6) = "表示"
042
043 Call Edit_Redact(sPDF, sText, iCount)
044
045 Debug.Print "End Time = " & Format(Time, "hh:mm:ss")
046 End Sub
047
048 '**************************************************
049 ' 関数：PDF上のテキストを墨消しにする
050 '
051 ' 注意 ：テキストは削除されます。
052 ' Create : 2026/03/20
053 ' Update :
054 ' Vertion : 1.0.0
055 ' https://pdf-file.nnn2.com/?p=1217
056 '**************************************************
057
058 Sub Edit_Redact(ByRef sPDF() As String, _
059 ByRef sText() As String, _
060 ByRef iCount() As Long)
061
062 Dim i As Long
063 Dim x As Long
064 Dim bRet As Boolean
065 Dim sFilePathIn As String
066 Dim iOutCnt As Long
067 Dim gSerch() As type_SerchTexts
068 Dim gRects() As type_TextRect
069
070 For x = 0 To UBound(sPDF)
071
072 '----------------------------------
073 ' テキストの座標を得る
074 i = UBound(sText)
075 ReDim gSerch(i) As type_SerchTexts
076 For i = 0 To UBound(sText)
077 gSerch(i).sSerchText = sText(i)
078 Next i
079 sFilePathIn = sPDF(x)
080
081 '▼PDF上をテキスト検索し、そのページ番号と座標を取得
082 'URL： https://pdf-file.nnn2.com/?p=1099
083 bRet = GetTextsGetRects(sFilePathIn, -1, -1, _
084 gSerch, gRects, iOutCnt)
085
086 iCount(x) = iOutCnt + 1
087
088 Dim sQuads As String
089 Dim sAJS As String
090 Dim sReturn As String
091
092 Dim objAcroApp As New Acrobat.AcroApp
093 Dim objAcroAVDoc As New Acrobat.AcroAVDoc
094 Dim objAcroPDDoc As New Acrobat.AcroPDDoc
095 Dim objAFormApp As New AFORMAUTLib.AFormApp
096 Dim objAFormFields As AFORMAUTLib.Fields
097
098 Const sAcrobatJavaScript3 = _
099 "oRet = this.addAnnot({" & _
100 " type: 'Redact'," & _
101 " quads:[@q] ," & _
102 " page:@p ," & _
103 " fillColor: color.black " & _
104 "});"
105
106 'ACrobat OLEエラー対策
107 objAcroApp.CloseAllDocs
108 objAcroApp.Hide
109
110 'PDFファイルを開く
111 bRet = objAcroAVDoc.Open(sFilePathIn, "")
112 If Not bRet Then Stop
113 Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
114 Set objAFormFields = objAFormApp.Fields
115
116 For i = 0 To iOutCnt '-1はゼロ件
117 With gRects(i)
118 sAJS = sAcrobatJavaScript3
119 sAJS = Replace(sAJS, "@q", EditQuads_8item(.sQuads))
120 sAJS = Replace(sAJS, "@p", .iPageNo)
121 End With
122 '▼Acrobat JavaScript の実行
123 sReturn = objAFormFields.ExecuteThisJavascript(sAJS)
124 Next i
125
126 '----------------------------------
127 '▼墨消し適用
128 If iOutCnt >= 0 Then
129 bRet = objAcroApp.MenuItemExecute("DoRedactMenu")
130 If Not bRet Then Stop
131 End If
132
133 '▼PDFファイルを別名で保存
134 Dim sFilePathOut As String
135 sFilePathOut = Replace(sFilePathIn, ".pdf", _
136 "_" & (iOutCnt + 1) & ".pdf")
137 If objAcroPDDoc.Save(1, sFilePathOut) = False Then
138 MsgBox "PDFファイルへ保存出来ませんでした", _
139 vbOKOnly + vbCritical, "実行エラー"
140 End If
141
142 '----------------------------------
143
144 '変更しないで閉じます。
145 bRet = objAcroAVDoc.Close(False)
146 If Not bRet Then Stop
147
148 Next x
149
150 On Error Resume Next
151 'Acrobatアプリケーションの終了
152 objAcroApp.Hide
153 objAcroApp.Exit
154 'オブジェクトの開放
155 Set objAFormFields = Nothing
156 Set objAFormApp = Nothing
157 Set objAcroPDDoc = Nothing
158 Set objAcroAVDoc = Nothing
159 Set objAcroApp = Nothing
160 End Sub
161
162 '**************************************************
163 '
164 ' Quads値を８値で１組に変換する
165 '
166 ' Create : 2020/06/08
167 ' Version: 1.0.0
168 '
169 ' 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 ->
170 ' [1,2,3,4,5,6,7,8],[9,10,11,12,13,14,15]
171 '
172 '**************************************************
173 Private Function EditQuads_8item(ByVal sQuads As String)
174 Dim sWk() As String
175 Dim sQ As String
176 Dim i1 As Long
177 EditQuads_8item = ""
178 sWk = Split(sQuads, ",")
179 For i1 = 0 To UBound(sWk) Step 8
180 sQ = "[" & sWk(i1 + 0) & ","
181 sQ = sQ + sWk(i1 + 1) & ","
182 sQ = sQ + sWk(i1 + 2) & ","
183 sQ = sQ + sWk(i1 + 3) & ","
184 sQ = sQ + sWk(i1 + 4) & ","
185 sQ = sQ + sWk(i1 + 5) & ","
186 sQ = sQ + sWk(i1 + 6) & ","
187 sQ = sQ + sWk(i1 + 7) & "]"
188 If EditQuads_8item <> "" Then _
189 EditQuads_8item = EditQuads_8item & ","
190 EditQuads_8item = EditQuads_8item & sQ
191 Next i1
192 End Function
193
194 '*********************************************
195 ' メモリ上のAcrobatプロセスを数える。
196 '*********************************************
197 Private Function iCheckAcrobat() As Long
198 'On Error GoTo skip_iCheckAcrobat: 'VBA実行時エラー
199 Dim items As Object
200 Set items = CreateObject("WbemScripting.SWbemLocator") _
201 .ConnectServer.ExecQuery( _
202 "Select * From Win32_Process " & _
203 "Where Name = 'Acrobat.exe'")
204 '1以上はプロセス有り、0は無し
205 iCheckAcrobat = items.Count
206 ' Exit Function
207 'skip_iCheckAcrobat:
208 ' miErrorNo = Err.Number
209 ' msErrorMsg = Err.Description
210 End Function
211
212 '*********************************************
213 ' メモリ上に残ったAcrobatプロセスを
214 ' 正常に終了させる為だけの処理です。
215 '*********************************************
216 Sub EndAcrobat()
217 On Error Resume Next
218 Dim objAcroApp As New Acrobat.AcroApp
219 Dim objAcroAVDoc As New Acrobat.AcroAVDoc
220 Dim objAcroPDDoc As New Acrobat.AcroPDDoc
221 Dim objAFormApp As New AFORMAUTLib.AFormApp
222 Dim objAFormFields As AFORMAUTLib.Fields
223
224 objAcroApp.CloseAllDocs
225 objAcroApp.Hide
226 objAcroApp.Exit
227
228 Set objAFormFields = Nothing
229 Set objAFormApp = Nothing
230 Set objAcroPDDoc = Nothing
231 Set objAcroAVDoc = Nothing
232 Set objAcroApp = Nothing
233
234 '上記の実行後にメモリ上から消える、はず。
235 MsgBox "Acrobat OLEの終了を試みました。" & _
236 vbCrLf & "10秒後にメモリから消えたのを" & _
237 vbCrLf & "タスクマネージャーで確認して下さい。", _
238 vbSystemModal + vbInformation, "お知らせ"
239 End Sub
M_GetTextsGetRects.bas：
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 : 2026/03/18
110 ' Vertion : 3.0.1
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 New 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 Private Function bCheckKigouSpaceLF( _
541 ByVal sText As String, _
542 ByVal bSpace As Boolean, _
543 ByVal bCRLF As Boolean, _
544 ByVal bLF As Boolean) As Boolean
545
546 Dim sWk As String
547 sWk = Right(sText, 1)
548 If Len(sWk) <> LenB(StrConv(sWk, vbFromUnicode)) Then
549 '全角文字
550 bCheckKigouSpaceLF = False
551 Exit Function
552 End If
553 Dim sCode As String
554 '文字コードを取得
555 sCode = Asc(sWk)
556 '文字コードで半角英数字のチェック
557 If (sCode >= 48 And sCode <= 57) Then
558 '半角 0～9
559 bCheckKigouSpaceLF = False
560 ElseIf (sCode >= 65 And sCode <= 90) Then
561 '半角 A～Z 英字大文字
562 bCheckKigouSpaceLF = False
563 ElseIf (sCode >= 97 And sCode <= 122) Then
564 '半角 a～z 英字小文字
565 bCheckKigouSpaceLF = False
566 Else
567 '半角記号
568 If bSpace And bLF Then
569 bCheckKigouSpaceLF = True
570 Else
571 bCheckKigouSpaceLF = False
572 End If
573 End If
574 End Function
575
576 '**************************************************
577 '
578 ' マージできるQuads値を探して、処理する。
579 '
580 ' 前後のQuads値の隣接する座標を比較し、
581 ' 差が全て 1.0 以内ならばマージする'
582 '
583 ' Create : 2020/06/07
584 ' Version: 1.0.0
585 '
586 ' 比較する箇所：
587 ' 前の座標 後の座標
588 ' 2x <-> 1x
589 ' 2y <-> 1y
590 ' 4x <-> 3x
591 ' 4y <-> 3y
592 '**************************************************
593 Private Sub CheckQuads_Merge2( _
594 ByRef gRects() As type_TextRect)
595
596 Dim i1 As Long
597 Dim i2 As Long
598 Dim i3 As Long
599 Dim i4 As Long
600 Dim sWk1() As String
601 Dim sWk2() As String
602 Dim bMerge As Boolean 'True：マージ処理をした
603
604 For i1 = 0 To UBound(gRects)
605 bMerge = False
606 sWk1 = Split(gRects(i1).sQuads, ",")
607 If UBound(sWk1) > 7 Then
608 ReDim sWk2(UBound(sWk1)) As String
609 For i2 = 0 To 7
610 sWk2(i2) = sWk1(i2)
611 sWk1(i2) = ""
612 Next i2
613 i2 = 8
614 i3 = 0
615 Do Until i2 > UBound(sWk1)
616 '隣接する部分の差を比較
617 If Abs(Val(sWk2(i3 + 2)) - Val(sWk1(i2 + 0))) < CON_SA2 And _
618 Abs(Val(sWk2(i3 + 3)) - Val(sWk1(i2 + 1))) < CON_SA2 And _
619 Abs(Val(sWk2(i3 + 6)) - Val(sWk1(i2 + 4))) < CON_SA2 And _
620 Abs(Val(sWk2(i3 + 7)) - Val(sWk1(i2 + 5))) < CON_SA2 Then
621 '２つの座標をマージする
622 ' sWk2(i3 + 0) = sWk1(i2 + 0) '1x
623 ' sWk2(i3 + 1) = sWk1(i2 + 1) '1y
624 sWk2(i3 + 2) = sWk1(i2 + 2) '2x
625 sWk2(i3 + 3) = sWk1(i2 + 3) '2y
626 ' sWk2(i3 + 4) = sWk1(i2 + 4) '3x
627 ' sWk2(i3 + 5) = sWk1(i2 + 5) '3y
628 sWk2(i3 + 6) = sWk1(i2 + 6) '4x
629 sWk2(i3 + 7) = sWk1(i2 + 7) '4y
630 i2 = i2 + 8
631 bMerge = True
632 Else
633 'マージできないのでそのままコピー
634 i3 = i3 + 8
635 For i4 = 0 To 7
636 sWk2(i3 + i4) = sWk1(i2)
637 sWk1(i2) = ""
638 i2 = i2 + 1
639 Next i4
640 End If
641 Loop
642 If bMerge Then
643 'マージ処理をしたので結果を返す
644 With gRects(i1)
645 .sQuads = ""
646 For i2 = 0 To UBound(sWk2)
647 If sWk2(i2) <> "" Then
648 If .sQuads <> "" Then _
649 .sQuads = .sQuads & ","
650 .sQuads = .sQuads & sWk2(i2)
651 End If
652 Next i2
653 End With
654 End If
655 End If
656 Next i1
657 End Sub
658
659 '**************************************************
660 '
661 ' 空白の座標を追加する。
662 '
663 ' 最初のQuads値の後８座標の2x,2y,4x,4y と
664 ' 後 のQuads値の前８座標の1x,1y,3x,3y を使って
665 ' 間の空白用の座標を作成する。
666 ' 但し、次が改行の時はマージ可能座標を追加する。
667 '
668 ' Create : 2020/06/09
669 ' Version: 1.0.0
670 '
671 '**************************************************
672 Private Sub AddQuadsSpace( _
673 ByRef sQuads As String, _
674 ByVal sQuads_AF As String, _
675 ByVal bCRLF As Boolean, _
676 ByVal bLF As Boolean)
677
678 Dim sWk1() As String
679 Dim sWk2() As String
680 Dim sSpace(7) As String
681 Dim i1 As Long
682
683 sWk1 = Split(Trim(sQuads), ",")
684 sWk2 = Split(Trim(sQuads_AF), ",")
685 i1 = UBound(sWk1) - 7
686 sSpace(0) = sWk1(i1 + 2) '1x
687 sSpace(1) = sWk1(i1 + 3) '1y
688 If bCRLF Or bLF Then
689 sSpace(2) = sSpace(0) '2x
690 sSpace(3) = sSpace(1) '2y
691 Else
692 sSpace(2) = sWk2(0) '2x
693 sSpace(3) = sWk2(1) '2y
694 End If
695 sSpace(4) = sWk1(i1 + 6) '3x
696 sSpace(5) = sWk1(i1 + 7) '3y
697 If bCRLF Or bLF Then
698 sSpace(6) = sSpace(4) '2x
699 sSpace(7) = sSpace(5) '2y
700 Else
701 sSpace(6) = sWk2(4) '4x
702 sSpace(7) = sWk2(5) '4y
703 End If
704 For i1 = 0 To 7
705 sQuads = sQuads & "," & sSpace(i1)
706 Next i1
707 End Sub
708
709 '**************************************************
710 '
711 ' ２つのQuads値をマージ
712 '
713 ' 以下のAが出来たらBはスキップ。
714 ' 以下のAが出来ない時はBを試す。
715 '
716 ' A)S2の全てのQuads値＝S2と同じ数の後のQuads値
717 ' S1にS2の値が含まれている、として
718 ' そのままS1を返す。※J1-J2パターン(E)に対応
719 '
720 ' B)最初のQuads値の後８座標の2x,2y,4x,4y を
721 ' 後のQuads値の前８座標の2x,2y,4x,4y に置き換える。
722 '
723 ' Create : 2020/06/07
724 ' Version: 1.0.0
725 '
726 '**************************************************
727 Private Sub MargeSameQuads8( _
728 ByRef sQuads As String, _
729 ByVal sQuads_Add As String)
730
731 Dim sWk1() As String
732 Dim sWk2() As String
733 Dim i1 As Long
734 Dim i2 As Long
735 Dim i3 As Long
736 Dim i4 As Long
737
738 sWk1 = Split(Trim(sQuads), ",")
739 sWk2 = Split(Trim(sQuads_Add), ",")
740 i1 = UBound(sWk1)
741 i2 = UBound(sWk2)
742
743 'A) 何もしない
744 If i1 >= i2 Then
745 i4 = i1
746 For i3 = UBound(sWk2) To 0 Step -1
747 If sWk1(i4) <> sWk2(i3) Then _
748 GoTo MargeSameQuads8_Skip:
749 i4 = i4 - 1
750 Next i3
751 Exit Sub
752 End If
753
754 MargeSameQuads8_Skip:
755 'B) マージ
756 ' sWk1(i1 - 7) = '1x
757 ' sWk1(i1 - 6) = '1y
758 sWk1(i1 - 5) = sWk2(2) '2x
759 sWk1(i1 - 4) = sWk2(3) '2y
760 ' sWk1(i1 - 3) = '3x
761 ' sWk1(i1 - 2) = '3y
762 sWk1(i1 - 1) = sWk2(6) '4x
763 sWk1(i1 - 0) = sWk2(7) '4y
764 '結果を戻す
765 sQuads = ""
766 For i1 = 0 To UBound(sWk1)
767 If sQuads <> "" Then sQuads = sQuads & ","
768 sQuads = sQuads & sWk1(i1)
769 Next i1
770 End Sub
771
772 '**************************************************
773 '
774 ' テキストとQuads値を分割する
775 '
776 ' Create : 2020/06/07
777 ' Version: 1.0.0
778 '
779 ' テキストとQuads値だけを分割する。
780 ' 他の情報は呼び出し元で追加等をする。
781 '
782 ' iAddNpについて：
783 ' １文字テキスト単位での終了状態を判断する時の
784 ' 位置を示す。J2のテキストの終了状態はこの値で
785 ' セットした位置で判断できるようにする。
786 ' しかし実際はJ2では見なく、J1の配列を見て判断
787 ' しているので、この結果は反映されてない。
788 '
789 '**************************************************
790 Private Sub SplitQuadsText( _
791 ByVal sTextIn As String, _
792 ByVal sQuadsIn As String, _
793 ByVal bSpace As Boolean, _
794 ByVal bCRLF As Boolean, _
795 ByVal bCR As Boolean, _
796 ByVal bLF As Boolean, _
797 ByRef sTextOut() As String, _
798 ByRef sQuadsOut() As String, _
799 ByRef iAddNo As Long, _
800 ByRef iMno() As Long)
801
802 sTextIn = Trim(sTextIn)
803 sQuadsIn = Trim(sQuadsIn)
804 ReDim sTextOut(0) As String
805 ReDim sQuadsOut(0) As String
806 sTextOut(0) = sTextIn
807 sQuadsOut(0) = sQuadsIn
808
809 If Trim(sQuadsIn) = "" Or _
810 Trim(sTextIn) = "" Then
811 Stop 'プログラムエラー
812 Exit Sub
813 End If
814
815 Dim sQin() As String
816 sQin = Split(sQuadsIn, ",")
817 If UBound(sQin) = 7 Then
818 Stop 'プログラムエラー
819 Exit Sub
820 End If
821 If UBound(sQin) < 7 Then
822 'Quads値の数が７以下
823 Stop 'プログラムエラー
824 Exit Sub
825 End If
826 If (UBound(sQin) + 1) / 8 <> _
827 Int((UBound(sQin) + 1) / 8) Then
828 'Quads値の数が８の倍数で無い
829 Stop 'プログラムエラー
830 Exit Sub
831 End If
832
833 Dim i1 As Long
834 Dim i3 As Long
835 i1 = (UBound(sQin) + 1) / 8
836
837 '▼(B)文字数＝Quadsの組数
838 If Len(sTextIn) = i1 Then
839 ReDim sTextOut(i1 - 1) As String
840 ReDim sQuadsOut(i1 - 1) As String
841 ReDim iMno(i1 - 1) As Long
842 For i3 = 0 To i1 - 1
843 sTextOut(i3) = Mid(sTextIn, i3 + 1, 1)
844 sQuadsOut(i3) = SlplitQuads_8Item(sQuadsIn, i3)
845 giMergeNo = giMergeNo + 1
846 iMno(i3) = giMergeNo
847 Next i3
848 iAddNo = Len(sTextIn) - 1
849 Exit Sub
850 End If
851
852 '▼(A)文字数＜Quadsの組数 ※稀に有る
853 If Len(sTextIn) < i1 Then
854 i1 = Len(sTextIn) 'テキストの長さに合わせる
855 ReDim sTextOut(i1 - 1) As String
856 ReDim sQuadsOut(i1 - 1) As String
857 ReDim iMno(i1 - 1) As Long
858 For i3 = 0 To i1 - 1
859 sTextOut(i3) = Mid(sTextIn, i3 + 1, 1)
860 sQuadsOut(i3) = SlplitQuads_8Item(sQuadsIn, i3)
861 giMergeNo = giMergeNo + 1
862 iMno(i3) = giMergeNo
863 Next i3
864 '残りを最後に追加
865 For i3 = i1 To ((UBound(sQin) + 1) / 8) - 1
866 sQuadsOut(i1 - 1) = sQuadsOut(i1 - 1) _
867 & "," & SlplitQuads_8Item(sQuadsIn, i3)
868 Next i3
869 iAddNo = Len(sTextIn) - 1
870 Exit Sub
871 End If
872
873 Dim i2 As Long
874 Dim iCnt As Long
875 Dim sCode As String
876 Dim sWk() As String
877
878 Dim bAlphabetic As Boolean '半角英字
879 Dim iAlphabeticCnt As Long '半角英字の数
880 Dim bNumber As Boolean '半角数字
881 Dim iNumberCnt As Long '半角数字の数
882 Dim bUppercase As Boolean '半角英字大文字
883 Dim iUppercaseCnt As Long '半角英字大文字の数
884 Dim blowercase As Boolean '半角英字小文字
885 Dim ilowercaseCnt As Long '半角英字小文字の数
886 Dim bSymbol As Boolean '半角記号
887 Dim iSymbolCnt As Long '半角記号の数
888 Dim sSymbol As String '最初に見つかった半角記号の内容
889 Dim iSymbolFirst As Long '最初に見つかった半角記号の位置
890
891 bAlphabetic = False
892 bNumber = False
893 bUppercase = False
894 blowercase = False
895 bSymbol = False
896
897 iAlphabeticCnt = 0
898 iNumberCnt = 0
899 iUppercaseCnt = 0
900 ilowercaseCnt = 0
901 iSymbolCnt = 0
902 sSymbol = ""
903 iSymbolFirst = 0
904
905 '▽テキスト内の文字種をチェック
906 i1 = 1
907 Do While i1 <= Len(sTextIn)
908 '１文字単位で文字コードを取得
909 sCode = Asc(Mid(sTextIn, i1, 1))
910 '文字コードで半角英数字のチェック
911 If (sCode >= 48 And sCode <= 57) Then
912 '半角 0～9
913 bNumber = True
914 iNumberCnt = iNumberCnt + 1
915 ElseIf (sCode >= 65 And sCode <= 90) Then
916 '半角 A～Z 英字大文字
917 bAlphabetic = True
918 bUppercase = True
919 iAlphabeticCnt = iAlphabeticCnt + 1
920 iUppercaseCnt = iUppercaseCnt + 1
921 ElseIf (sCode >= 97 And sCode <= 122) Then
922 '半角 a～z 英字小文字
923 bAlphabetic = True
924 blowercase = True
925 iAlphabeticCnt = iAlphabeticCnt + 1
926 ilowercaseCnt = ilowercaseCnt + 1
927 Else
928 '半角記号
929 bSymbol = True
930 iSymbolCnt = iSymbolCnt + 1
931 If sSymbol = "" Then
932 '最初の記号の内容と位置
933 sSymbol = Mid(sTextIn, i1, 1)
934 iSymbolFirst = i1
935 End If
936 End If
937 i1 = i1 + 1
938 Loop
939
940 Dim sWk_Text() As String
941 Dim sWk_Quads() As String
942 Dim sTou() As String
943 Dim sQou() As String
944
945 '▼(C)継続文字「英字＋ハイフン＋英字」の分割
946 If (UBound(sQin) = 15 And _
947 bAlphabetic = True And _
948 sSymbol = "-" And _
949 1 < iSymbolFirst) And _
950 iSymbolFirst < Len(sTextIn) And _
951 (bSpace Or (bSpace And bLF) Or bCRLF) Then
952
953 ReDim sWk_Text(1) As String
954 ReDim sWk_Quads(1) As String
955 sWk_Text(0) = Left(sTextIn, iSymbolFirst - 1)
956 sWk_Text(1) = Mid(sTextIn, iSymbolFirst + 1)
957 sWk_Quads(0) = SlplitQuads_8Item(sQuadsIn, 0)
958 'ハイフン分のQuads値を削除する
959 sWk_Quads(0) = CutHaifunQ(sWk_Quads(0), iSymbolFirst)
960 sWk_Quads(1) = SlplitQuads_8Item(sQuadsIn, 1)
961
962 '１文字単位に分割
963 i1 = Len(sTextIn) - 2
964 ReDim sTextOut(i1) As String
965 ReDim sQuadsOut(i1) As String
966 ReDim iMno(i1) As Long
967 iCnt = -1
968 For i2 = 0 To 1
969 giMergeNo = giMergeNo + 1
970 If Len(sWk_Text(i2)) = 1 Then
971 iCnt = iCnt + 1
972 sTextOut(iCnt) = sWk_Text(i2)
973 sQuadsOut(iCnt) = sWk_Quads(i2)
974 iMno(iCnt) = giMergeNo
975 Else
976 Call SplitQuadsCalc(sWk_Text(i2), sWk_Quads(i2), sTou, sQou)
977 For i3 = 0 To UBound(sTou)
978 iCnt = iCnt + 1
979 sTextOut(iCnt) = sTou(i3)
980 sQuadsOut(iCnt) = sQou(i3)
981 iMno(iCnt) = giMergeNo
982 Next i3
983 End If
984 If i2 = 0 Then iAddNo = iCnt
985 Next i2
986 Exit Sub
987 End If
988
989 '▼(D)大文字英字＋小文字英字＋大文字英字
990 Dim sWk2() As String
991 ReDim sWk2(Len(sTextIn)) As String
992 i2 = -1
993 For i1 = 1 To Len(sTextIn)
994 '１文字の文字コードを取得
995 sCode = Asc(Mid(sTextIn, i1, 1))
996 '文字コードで半角英数字のチェック
997 If (sCode >= 65 And sCode <= 90) Then
998 '半角英字(A～Z)
999 i2 = i2 + 1
1000 sWk2(i2) = Mid(sTextIn, i1, 1)
1001 Else
1002 '半角英字(A～Z)以外
1003 If i2 = -1 Then i2 = 0
1004 sWk2(i2) = sWk2(i2) & Mid(sTextIn, i1, 1)
1005 End If
1006 Next i1
1007 If (UBound(sQin) + 1) / 8 = (i2 + 1) Then
1008 '大文字で区切るとQuads組数と同じ
1009 ReDim sWk_Text(i2) As String
1010 ReDim sWk_Quads(i2) As String
1011 '１文字が１Quads値
1012 For i3 = 0 To i2
1013 sWk_Text(i3) = sWk2(i3)
1014 sWk_Quads(i3) = SlplitQuads_8Item(sQuadsIn, i3)
1015 Next i3
1016 iCnt = -1
1017 ReDim sTextOut(Len(sTextIn) - 1) As String
1018 ReDim sQuadsOut(Len(sTextIn) - 1) As String
1019 ReDim iMno(Len(sTextIn) - 1) As Long
1020 For i1 = 0 To i2
1021 Call SplitQuadsCalc( _
1022 sWk_Text(i1), sWk_Quads(i1), sTou, sQou)
1023 giMergeNo = giMergeNo + 1
1024 For i3 = 0 To UBound(sTou)
1025 iCnt = iCnt + 1
1026 sTextOut(iCnt) = sTou(i3)
1027 sQuadsOut(iCnt) = sQou(i3)
1028 iMno(iCnt) = giMergeNo
1029 Next i3
1030 Next i1
1031 iAddNo = iCnt
1032 Exit Sub
1033 End If
1034
1035 '▼(E)分割できないQuads値
1036 ' 文字数＞Quadsの組数 ※かなり有る
1037 If Len(sTextIn) > ((UBound(sQin) + 1) / 8) Then
1038 ReDim sTextOut(Len(sTextIn) - 1) As String
1039 ReDim sQuadsOut(Len(sTextIn) - 1) As String
1040 ReDim iMno(Len(sTextIn) - 1) As Long
1041 giMergeNo = giMergeNo + 1
1042 For i3 = 0 To Len(sTextIn) - 1
1043 sTextOut(i3) = Mid(sTextIn, i3 + 1, 1)
1044 sQuadsOut(i3) = sQuadsIn
1045 iMno(i3) = giMergeNo
1046 Next i3
1047 iAddNo = Len(sTextIn) - 1
1048 Exit Sub
1049 End If
1050
1051 Stop 'プログラムエラー
1052 End Sub
1053
1054 '**************************************************
1055 '
1056 ' Quads値の右端から1文字分の座標を削除する。
1057 '
1058 ' Create : 2020/06/07
1059 ' Version: 1.0.0
1060 '
1061 ' テキスト途中にハイフンが入ったテキストの
1062 ' ハイフン前のテキスト用のQuads座標から
1063 ' ハイフンの１文字分の座標を削除する。
1064 '
1065 '**************************************************
1066 Private Function CutHaifunQ( _
1067 ByVal sQu As String, _
1068 ByVal iLen As Long) As String
1069
1070 Dim i1 As Long
1071 Dim iX1 As Double
1072 Dim iX2 As Double
1073 Dim iY1 As Double
1074 Dim iY2 As Double
1075 Dim sWk() As String
1076
1077 If Trim(sQu) = "" Then Stop
1078 If iLen = 0 Then Stop
1079 sWk = Split(sQu, ",")
1080 iX1 = (Val(sWk(JZ2.i2x)) - Val(sWk(JZ2.i1x))) / iLen
1081 iX2 = (Val(sWk(JZ2.i4x)) - Val(sWk(JZ2.i3x))) / iLen
1082 iY1 = (Val(sWk(JZ2.i2y)) - Val(sWk(JZ2.i1y))) / iLen
1083 iY2 = (Val(sWk(JZ2.i4y)) - Val(sWk(JZ2.i3y))) / iLen
1084 CutHaifunQ = sWk(JZ2.i1x)
1085 CutHaifunQ = CutHaifunQ & "," & sWk(JZ2.i1y)
1086 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i2x) - iX1)
1087 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i2y) - iY1)
1088 CutHaifunQ = CutHaifunQ & "," & sWk(JZ2.i3x)
1089 CutHaifunQ = CutHaifunQ & "," & sWk(JZ2.i3y)
1090 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i4x) - iX2)
1091 CutHaifunQ = CutHaifunQ & "," & Val(sWk(JZ2.i4y) - iY2)
1092 End Function
1093
1094 '**************************************************
1095 '
1096 ' Quads値の整合性をチェックする
1097 '
1098 ' Create : 2020/06/07
1099 ' Version: 1.0.0
1100 '
1101 ' 戻り値 ：True エラー無し
1102 ' ：False エラー有り
1103 '
1104 '**************************************************
1105 Private Function CheckQuadsData( _
1106 ByVal sQuads As String) As Boolean
1107 On Error GoTo Err_CheckQuadsData:
1108 Dim sWk() As String
1109 Dim i1 As Long
1110 If Trim(sQuads) = "" Then
1111 CheckQuadsData = False
1112 Exit Function
1113 End If
1114 '配列が８の倍数
1115 sWk = Split(sQuads, ",")
1116 If UBound(sWk) < 7 Or _
1117 (Int((UBound(sWk) + 1) / 8) <> ((UBound(sWk) + 1) / 8)) Then
1118 CheckQuadsData = False
1119 Exit Function
1120 End If
1121 'データが数値
1122 For i1 = 0 To UBound(sWk)
1123 If Not IsNumeric(sWk(i1)) Or _
1124 Trim(sWk(i1)) = "" Then
1125 CheckQuadsData = False
1126 Exit Function
1127 End If
1128 Next i1
1129 CheckQuadsData = True
1130 Exit Function
1131
1132 Err_CheckQuadsData:
1133 CheckQuadsData = False
1134 End Function
1135
1136 '**************************************************
1137 '
1138 ' Quads値の前処理
1139 '
1140 ' 1組のQuads値の前後の差が0.5以内ならば
1141 ' 同じQuads組と扱い、後のQuads値を削除する。
1142 ' 削除後は空いた部分に後を詰める。
1143 '
1144 ' Create : 2020/06/07
1145 ' Version: 1.0.0
1146 '
1147 ' 稀だがこの様なQuads値が存在する。削除する。
1148 '
1149 '**************************************************
1150 Private Sub PreprocessingQuads(ByRef sQuads As String)
1151 Dim sWk() As String
1152 Dim i1 As Long
1153 Dim i2 As Long
1154 Dim i3 As Long
1155 Dim i4 As Long
1156 Dim bDel As Boolean
1157 Dim iSkip As Long
1158
1159 sWk = Split(sQuads, ",")
1160 If UBound(sWk) = 7 Then Exit Sub
1161
1162 bDel = False
1163 For i1 = 0 To ((UBound(sWk) + 1) / 8 - 1)
1164 If sWk((i1 + 1) * 8) = "" Then Exit For
1165 iSkip = 0
1166 For i2 = 0 To 7
1167 If Abs(Val(sWk((i1 * 8) + i2)) - _
1168 Val(sWk(((i1 + 1) * 8) + i2))) < CON_SA1 Then
1169 iSkip = iSkip + 1
1170 End If
1171 Next i2
1172
1173 If iSkip = 8 Then
1174 '同じQuads値は削除する
1175 bDel = True
1176 For i3 = 0 To 7
1177 sWk((i1 + 1) * 8 + i3) = ""
1178 Next i3
1179 If ((i1 + 1) * 8 + 8) >= UBound(sWk) Then Exit For
1180
1181 '同じQuads値は無視して、前に詰める
1182 For i3 = (i1 + 1) To ((UBound(sWk) + 1) / 8 - 2)
1183 For i4 = 0 To 7
1184 sWk(i3 * 8 + i4) = sWk((i3 + 1) * 8 + i4)
1185 sWk((i3 + 1) * 8 + i4) = ""
1186 Next i4
1187 Next i3
1188 i1 = i1 - 1
1189 End If
1190 If (i1 + 1) >= ((UBound(sWk) + 1) / 8 - 1) Then Exit For
1191 Next i1
1192
1193 If bDel Then
1194 'Quads値を戻す
1195 sQuads = ""
1196 For i1 = 0 To UBound(sWk)
1197 If sWk(i1) <> "" Then
1198 If sQuads <> "" Then sQuads = sQuads & ","
1199 sQuads = sQuads & sWk(i1)
1200 End If
1201 Next i1
1202 End If
1203 End Sub
1204
1205 '**************************************************
1206 '
1207 ' テキストを１文字単位で分割し、
1208 ' Quads値を計算で出す。
1209 '
1210 ' 1)テキストが２文字以上：例「ABC」
1211 ' 2)Quads数＝８ ：例「1,2,3,4,5,6,7,8」
1212 '
1213 ' Create : 2020/06/07
1214 ' Version: 1.0.0
1215 '
1216 '**************************************************
1217 Public Sub SplitQuadsCalc( _
1218 ByVal sTextIn As String, _
1219 ByVal sQuadsIn As String, _
1220 ByRef sTou() As String, _
1221 ByRef sQou() As String)
1222
1223 Dim i1 As Long
1224 Dim sWk() As String
1225 Dim iX1 As Double
1226 Dim iX2 As Double
1227 Dim iY1 As Double
1228 Dim iY2 As Double
1229
1230 sTextIn = Trim$(sTextIn)
1231 If sTextIn = "" Then Stop
1232 sQuadsIn = Trim$(sQuadsIn)
1233 If sQuadsIn = "" Then Stop
1234
1235 sWk = Split(sQuadsIn, ",")
1236 ' If Len(sTextIn) = 1 Or _
1237 ' UBound(sWk) <> 7 Then Stop
1238
1239 ReDim sTou(Len(sTextIn) - 1) As String
1240 ReDim sQou(Len(sTextIn) - 1) As String
1241 If Len(sTextIn) = 1 Then
1242 sTou(0) = sTextIn
1243 sQou(0) = sQuadsIn
1244 Exit Sub
1245 End If
1246 iX1 = (Val(sWk(JZ2.i2x)) - Val(sWk(JZ2.i1x))) / Len(sTextIn)
1247 iX2 = (Val(sWk(JZ2.i4x)) - Val(sWk(JZ2.i3x))) / Len(sTextIn)
1248 iY1 = (Val(sWk(JZ2.i2y)) - Val(sWk(JZ2.i1y))) / Len(sTextIn)
1249 iY2 = (Val(sWk(JZ2.i4y)) - Val(sWk(JZ2.i3y))) / Len(sTextIn)
1250 For i1 = 0 To UBound(sTou)
1251 sTou(i1) = Mid(sTextIn, i1 + 1, 1)
1252 sQou(i1) = ""
1253 sQou(i1) = sQou(i1) & IIf(i1 = 0, _
1254 sWk(JZ2.i1x), Val(sWk(JZ2.i1x)) + (iX1 * i1))
1255 sQou(i1) = sQou(i1) & "," & IIf(i1 = 0, _
1256 sWk(JZ2.i1y), Val(sWk(JZ2.i1y)) + (iY1 * i1))
1257 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1258 sWk(JZ2.i2x), Val(sWk(JZ2.i1x)) + (iX1 * (i1 + 1)))
1259 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1260 sWk(JZ2.i2y), Val(sWk(JZ2.i1y)) + (iY1 * (i1 + 1)))
1261 sQou(i1) = sQou(i1) & "," & IIf(i1 = 0, _
1262 sWk(JZ2.i3x), Val(sWk(JZ2.i3x)) + (iX2 * i1))
1263 sQou(i1) = sQou(i1) & "," & IIf(i1 = 0, _
1264 sWk(JZ2.i3y), Val(sWk(JZ2.i3y)) + (iY2 * i1))
1265 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1266 sWk(JZ2.i4x), Val(sWk(JZ2.i3x)) + (iX2 * (i1 + 1)))
1267 sQou(i1) = sQou(i1) & "," & IIf(i1 = UBound(sTou), _
1268 sWk(JZ2.i4y), Val(sWk(JZ2.i3y)) + (iY2 * (i1 + 1)))
1269 Next i1
1270 End Sub
1271
1272 '**************************************************
1273 '
1274 ' Quads値の整合性をチェックする
1275 '
1276 ' Create : 2020/06/07
1277 ' Version: 1.0.0
1278 '
1279 ' 戻り値 ：True エラー無し
1280 ' ：False エラー有り
1281 '
1282 '**************************************************
1283 Public Function CheckQuads( _
1284 ByVal sQuads As String) As Boolean
1285 On Error GoTo Err_CheckQuads:
1286 Dim sWk() As String
1287 Dim i1 As Long
1288 If Trim(sQuads) = "" Then
1289 CheckQuads = False
1290 Exit Function
1291 End If
1292 '配列が８の倍数
1293 sWk = Split(sQuads, ",")
1294 If UBound(sWk) < 7 Or _
1295 (Int((UBound(sWk) + 1) / 8) <> ((UBound(sWk) + 1) / 8)) Then
1296 CheckQuads = False
1297 Exit Function
1298 End If
1299 'データが数値
1300 For i1 = 0 To UBound(sWk)
1301 If Not IsNumeric(sWk(i1)) Or _
1302 Trim(sWk(i1)) = "" Then
1303 CheckQuads = False
1304 Exit Function
1305 End If
1306 Next i1
1307 CheckQuads = True
1308 Exit Function
1309 Err_CheckQuads:
1310 CheckQuads = False
1311 End Function
1312
1313 '**************************************************
1314 '
1315 ' 文字列のQuads値を８座標単位で分割して返す関数
1316 '
1317 ' sQuads：Quads値が入った文字列
1318 ' iIchi ：抽出位置。0から開始
1319 '
1320 ' Create : 2020/06/07
1321 ' Version: 1.0.0
1322 '
1323 '**************************************************
1324 Public Function SlplitQuads_8Item( _
1325 ByVal sQuads As String, _
1326 ByVal iIchi As Long) As String
1327
1328 Dim sWk() As String
1329 Dim i1 As Long
1330 iIchi = iIchi + 1
1331 SlplitQuads_8Item = ""
1332 sWk = Split(sQuads, ",")
1333 For i1 = (iIchi * 8 - 8) To iIchi * 8 - 1
1334 If SlplitQuads_8Item <> "" Then _
1335 SlplitQuads_8Item = SlplitQuads_8Item & ","
1336 SlplitQuads_8Item = SlplitQuads_8Item & sWk(i1)
1337 Next i1
1338 End Function
1339
1340 '**************************************************
1341 '
1342 ' 座標のQuads値より表示タイプを調べる
1343 '
1344 ' Create : 2020/06/07
1345 ' Version: 1.0.0
1346 '
1347 ' 備考 : Doubleで比較しないと対象外が出てしまう
1348 '
1349 '**************************************************
1350 Public Function CheckQuadsType( _
1351 ByVal sQuads As String) As Long
1352
1353 Dim ax As Double
1354 Dim ay As Double
1355 Dim bX As Double
1356 Dim bY As Double
1357 Dim cx As Double
1358 Dim cy As Double
1359 Dim dx As Double
1360 Dim dy As Double
1361
1362 If Trim(sQuads) = "" Then
1363 CheckQuadsType = zType.iEtc
1364 ' Stop
1365 Exit Function
1366 End If
1367
1368 Dim sWk() As String
1369 sWk = Split(sQuads, ",")
1370
1371 '▼座標の状態からタイプを出す
1372 ax = Val(sWk(2)) - Val(sWk(0))
1373 ay = Val(sWk(3)) - Val(sWk(1))
1374 bX = Val(sWk(6)) - Val(sWk(4))
1375 bY = Val(sWk(7)) - Val(sWk(5))
1376 cx = Val(sWk(0)) - Val(sWk(4))
1377 cy = Val(sWk(1)) - Val(sWk(5))
1378 dx = Val(sWk(2)) - Val(sWk(6))
1379 dy = Val(sWk(3)) - Val(sWk(7))
1380
1381 Dim i1 As Long
1382
1383 For i1 = 0 To 1
1384
1385 Select Case True
1386 Case (ay = 0 And bY = 0) And _
1387 (ax > 0 And bX > 0 And cy > 0 And dy > 0)
1388 '通常
1389 CheckQuadsType = zType.iNormal
1390 Case (ay = 0 And bY = 0) And _
1391 (ax > 0 And bX > 0 And cy > 0 And dy > 0)
1392 'イタリック
1393 CheckQuadsType = zType.iItalic
1394 Case (ay = 0 And bY = 0) And _
1395 (ax < 0 And bX < 0 And cy < 0 And dy < 0)
1396 '180度回転
1397 CheckQuadsType = zType.i180R
1398 Case (ax > 0 And ay > 0 And bX > 0 And bY > 0) And _
1399 (cy > 0 And dy > 0)
1400 '左向き(1-89)回転
1401 CheckQuadsType = zType.iLeft
1402 Case (ax > 0 And ay < 0 And bX > 0 And bY < 0) And _
1403 (cy > 0 And dy > 0)
1404 '右向き(1-89)回転
1405 CheckQuadsType = zType.iRight
1406 Case (ax < 0 And ay > 0 And bX < 0 And bY > 0) And _
1407 (cy < 0 And dy < 0)
1408 '左向き(91-179)回転
1409 CheckQuadsType = zType.iLeft_2
1410 Case (ax < 0 And ay < 0 And bX < 0 And bY < 0) And _
1411 (cy < 0 And dy < 0)
1412 '右向き(91-179)回転
1413 CheckQuadsType = zType.iRight_2
1414 '※以下はその他の直前（この位置）で判断しないと駄目
1415 Case (ax = 0 And bX = 0) And _
1416 (ay < 0 And bY < 0)
1417 '右90度回転
1418 CheckQuadsType = zType.iRight90R
1419 Case (ax = 0 And bX = 0) And _
1420 (ay > 0 And bY > 0)
1421 '左90度回転
1422 CheckQuadsType = zType.iLeft90R
1423
1424 Case Else
1425 '「その他」として扱う
1426 CheckQuadsType = zType.iEtc
1427 ' Stop
1428 End Select
1429
1430 If CheckQuadsType <> zType.iEtc Then Exit For
1431
1432 '「その他」の場合は誤差を考慮して再チェック
1433 '小数点以下は四捨五入
1434 ax = Val(Format(ax, "0"))
1435 ay = Val(Format(ay, "0"))
1436 bX = Val(Format(bX, "0"))
1437 bY = Val(Format(bY, "0"))
1438 cx = Val(Format(cx, "0"))
1439 cy = Val(Format(cy, "0"))
1440 dx = Val(Format(dx, "0"))
1441 dy = Val(Format(dy, "0"))
1442 Next i1
1443
1444 End Function
redactMenu3.js の内容：
// ===============================
// Add Redact Menu（Acrobat XI）
// pdf-file.nnn2.com 2026/3/17
// ===============================
// --- trusted function ---
var doRedact = app.trustedFunction(function () {
app.beginPriv();
try {
var doc = app.activeDocs[0];
if (!doc) {
app.alert("Error: The document is not open.");
return;
}
doc.applyRedactions();
//app.alert("The operation was successful");
} catch (e) {
app.alert("Error: "+e);
}
app.endPriv();
});
// --- Add Menu ---
app.addMenuItem({
cName: "DoRedactMenu",
cUser: "GoGoBlack",
cParent: "Edit",
cExec: "doRedact();",
nPos: 0
});
上記 Acrobat JavaScriptの各部の補足説明：※見なくても良いです。
- 「app.beginPriv();」から「app.endPriv();」の間でセキュリティ権限の昇格を行う
- 「app.alert("The operation was successful");」を実行するとAcrobat OLEでの操作が一時停止するので削除、デバッグ用
- 「DoRedactMenu」がAcrobat OLEから指定する内部メニュー名
- 「GoGoBlack」外部メニュー名は表示のみ。Acrobat OLEからは使用しないので何でもOK
- 日本語を使うとシンタックスエラーが出る場合が有るので英語のみ
墨消しにならない？
検索テキストが以下の様に「赤の枠」になっている場合は
redactMenu3.js のインストール先フォルダが間違っています。
運用方法：例
墨消しをするとテキストは完全に削除されます。黒消し前の状態で一旦終了し、目視で確認した後に墨消しを実施します。
１．最初にサンプル中の123行目「bRet = objAcroApp.MenuItemExecute("DoRedactMenu")」を削除します。その状態で実行するとPDFファイルは以下の様に墨消し対象になるテキストを赤い枠で囲みます。
２．Acrobatで該当PDFを表示します。墨消し対象外にしたい赤の枠をマウスで右クリックし、ポップアップメニューから削除を行います。
３．その後でAcrobatの編集メニューに有る「GoGoBlack」を実行します。赤い枠が全て墨消しになり、テキストも削除されます。
４．「アレ？間違っちゃった！」と気づいたら、この時点でファイル・メニューの「復帰」をクリックします。墨消し前の状態に戻ります。
注意：ファイルを保存して閉じてから、再度開いた時には「復帰」は出来ません。
5．最後にAcrobatのメニューから保存します。
Windowsの再起動
この関数を利用した処理を始める時はWindowsの再起動後にすることをお勧めします。Acrobat JavaScriptを起動して処理する為に稀に実行時エラーが出ます。詳細は「AFormAut特有のVBA実行エラー」に書きました。
また実行時エラーが出たらWindowsの再起動をして下さい。
参照
- 関数：検索した文字列のページ番号と座標を返す
これを元にして当関数を作成 - PDF上のテキストとその座標
動作確認した環境
- Windows XP + MS Excel 2007 32bit + Acrobat X Pro
- Windows 11 Pro 64bit + MS Excel 2021 32bit + Acrobat XI Pro
備考
- 関数ではなく、Callサブです。
- VBAサンプルのトップに明記しておくべきだったが。抽出テキスト等の配列は固定では無く「ReDim Preserve」で足りなくなったら配列数をその都度拡大します。制限は掛けてないので無限に拡大します。
- 検索したテキストは this.addAnnot でターゲットの赤い枠の状態にし、最後に一回だけapplyRedactionsの実行をして一括で墨消し状態にします。
- 「運用方法：例」では編集はAcrobatと書きましたが不要な赤い枠の削除だけならばReaderでも出来ます。もちろんReaderで保存も出来ます。但し、墨消しの実行はReaderでは出来ません。
- 将来的にセキュリティの扱いが厳しくなり、今回の様な方法では出来なくなるかもしれません。（予想
サイト管理人の技術メモ
これ以降はサイト管理者が当サイト又は当ページを維持＆管理するためのメモです。見る必要も無く公開用にも書いてません。
・数ファイルの処理なら、Acrobatのアクションの方が超簡単です。
・Acrobatの環境設定の変更は特にいらない。
・Acrobat JavaScriptにも実行にはセキュリティ権限なるものが存在する事を今回の件で初めて知る。
・Acrobatの環境設定のJavascriptやセキュリティ関連を変更したら、Acrobat JavaScript「applyRedactions」をAcrobat OLEからも直で実行できるかと試したが出来なかった。
・メニューには直ちに表示されない。特に初期起動時にはメニューに出て来ない。２回目、又はPDFファイルを表示した時にメニューに登場する。これに関してはAcrobat OLE側では意識する必要は無い。タイミングの問題と思っている。
・メニューを追加するredactMenu3.js内で日本語文字を使うとシンタックスエラーが起きる場合が有る。出ない場合も有る。環境やAcrobatバージョンにより変化するかもしれないので、日本語は一切使わないようにする。日本語の空白もやめる。
Acrobat SOAP 11.0
SyntaxError: unterminated string literal
23:Folder-Level:App:redactMenu2.js
エラーはAcrobat ProのJavaScriptデバッガーに上記の様に表示される。
・redactMenu3.js をAcrobat起動時に読み込み、その時点でredactMenu3.jsの内容が全てAcrobat本体（メモリ上？）に取り込まれるのだろう、と予測している。メニューからredactMenu3.jsファイルに一時的に制御が行くとは考えられない。
・redactMenu3.js をReader DCのインストール先の「"C:\Program Files\Adobe\Acrobat DC\Acrobat\Javascripts\redactMenu3.js"」にインストールしたら、GoGoBlackメニューが追加された。しかしセキュリティ権限でGoGoBlack（applyRedactions）実行は阻止された。
つまり、Readerでは Acrobat JavaScript「applyRedactions」は実行できない。
環境設定のセキュリティ（拡張）関連を試したが無理だった。問題ない。
・墨消ししたPDFファイルのサイズは１割ほど増える。本当に物理的に削除されたのだろうか？ PDFに限らずファイルへの保存は基本的に後ろに追加される「追記型フォーマット」。これは処理速度を優先し再構築する時間を無くす為。差分追加保存とも言うらしいがPDFファイルへの変更等はこれが基本。但し最適化、圧縮処理を行うと古い差分を削除して再構築するらしい。別名保存では無く、上書き保存だと再構築しないので墨消ししたテキストは物理的に差分として残ると言う情報も有るが、だからと言って復元する方法が有ると言う情報は全く見つからない。（知らんけど
・コレって公開しても大丈夫？