関数：PDFの文書プロパティ(概要)を更新

TOP > サンプル/関数 > 関数：PDFの文書プロパティ(概要)を更新 [...]

概要

SetInfo メソッドでは完全にPDFのプロパティを更新できない時に使用する関数です。PDFファイル内のメタデータ（XMP）と文書情報ディクショナリー（Info）に有る以下の項目を更新します。

タイトル
サブタイトル
作成者
キーワード　※上書きします。
著作権情報

機能

入力PDFから不要なオブジェクト類を消す為に最初に最適化します。
文書情報ディクショナリー(Info)情報を更新します。
メタデータ(XMP)を取り出して更新します。
結果を出力PDFへ最適化して保存します。
CON_DEBUG = True の時は各処理内容の詳細なログをテキストファイルへ出力します。

注意事項

キーワードに関して、当関数は上書きします。
SetInfo メソッド、GetInfoメソッド、Acrobatのプロパティ画面、Acrobatのプロパティの詳細(XMP)画面との内容はそれぞれ異なる場合が有ります。当関数では全ての結果が同じになるように処理をします。
※但し、次の「３.」の場合の注意点は回避出来ませんでした。
当関数では、作成者を２つ以上登録しようとしてもInfoデータ(GetInfo の結果)には1番目しか登録されません。
作成者、キーワードの文字列に小文字のカンマ「,」とセミコロン「;」は使用できません。区切り文字として判断されてしまう為です。
どうしても使用したい時は文字列の前後をダブルクオーテーションで囲ってください。※CSVデータの扱いと同じみたいです。
但しダブルクオーテーションを使うと予期せぬ結果になる場合があります。その場合はカンマとセミコロンを全角に変更してなどして判断してください。
メタデータ（XMP）と文書情報ディクショナリー（Info）の扱い方に疑問が有ります。AcrobatのOLEの動作に一部理解できない部分が有ります。よって必ず事前に動作確認をしてから、ご使用ください。
関数を動作させる前に CON_WORK_FOLDER 定数に作業フォルダを事前に指定する必要が有ります。指定方法はサンプル参照。

形式

001 [boolean] = PDF_Update_MXP_INFO (  _
002 　　String  sInputPdf , _
003 　　String  sOutputPDF , _
004 　　String  sTitle , _
005 　　String  sSubject  , _
006 　　String  sAuthor( ) , _
007 　　String  sKeywords( ) , _
008 　　String  sRights , _
009 　　String  sMessage  )

　Highlight：プログラミング言語のソースコードを構文で色分け (GUI編)
　

引数

第一引数 ( string sInputPdf ) :
入力PDF ファイルのフルパス
第二引数 ( string sOutputPDF ) :
出力PDF ファイルのフルパス
第三引数 ( string sTitle ) :
文書プロパティのタイトル
第四引数 ( string sSubject ) :
文書プロパティのサブタイトル
第五引数 ( string sAuthor( ) ) :
文書プロパティの作成者
配列で複数指定可能。但し注意有り。
第六引数 ( string sKeywords( ) ) :
文書プロパティのキーワード
配列で複数指定可能
第七引数 ( string sRights ) :
文書プロパティの著作権情報
第八引数 ( string sMessage ) :
関数内でエラー時のみにセットされるエラーメッセージ

「タイトル」、「サブタイトル」、「作成者」、「キーワード」、「著作権情報」を処理したくない時は vbNullChar をセットします。0バイト文字 ”” の時は該当の文書プロパティを空にします。詳細はサンプルを参照してください。

戻り値

True : 正常終了。
False : エラー有り。第八引数に詳細なエラーメッセージがセットされます。

サンプル

Test1.PDF の「タイトル」、「サブタイトル」、「作成者」、「キーワード」、「著作権情報」を更新し、Test1-OUT1.PDFで出力します。
- タイトル： "■①タイトル"
- サブタイトル： "■②サブタイトル"
- 作成者の１番目： "■③作成者１"
- 作成者の２番目： "■③作成者２"
- キーワードの１番目： "■④キーワード１"
- キーワードの２番目： "■④キーワード２"
- 著作権情報： "■⑤著作権情報"
作業フォルダは "D:¥Temp¥Log¥" です。CON_WORK_FOLDER
途中の処理内容をログとして作業フォルダへテキストファイル出力します。 CON_DEBUG = True
事前に参照設定が必要です。

＜以下サンプルの最終更新日時：2017/03/28 13:59＞

Download：sample-PDDocSetInfo.xls

001 Option Explicit
002 
003 Private sXml(4, 3)      As String
004 Private sMsg            As String
005 Private lRet            As Long
006     
007 Private Const CON_LAST_TAG = "</rdf:Description>"
008 'Infoの作成者とキーワードの区切り文字
009 Private Const CON_KUGIRI = ","
010  
011 '   デバッグ用
012 '   CON_DEBUG = False でLOG出力無し
013  
014 Private Const CON_DEBUG = True
015 Private Const CON_WORK_FOLDER = "D:\Temp\Log\"
016 Private msDebugLogFilePath      As String   'LOGファイルパス
017 Private mlDebugLogFileNo        As Long     'LOGファイルNO
018 Private msDebugLogCnt           As Long     'LOGの出力数
019 Private msDebugMsg              As String
020  
021  
022 '==================================================
023 '   テスト用の呼び出し側
024 '==================================================
025  
026 Sub Main_Demo()
027  
028     Dim sInputPdf       As String   '入力PDFファイル
029     Dim sOutputPDF      As String   '出力PDFファイル
030     
031     Dim sTitle          As String   'タイトル
032     Dim sSubject        As String   'サブタイトル
033     Dim sAuthor(1)      As String   '作成者
034     Dim sKeywords(1)    As String   'キーワード
035     Dim sRights         As String   '著作権情報
036     
037     Dim bRet            As Boolean  '戻り値
038     Dim sMessage        As String   'エラーメッセージ
039     
040     '入力PDFファイル
041     sInputPdf = "D:\Temp\Log\Test1.PDF"
042     '出力PDFファイル
043     sOutputPDF = "D:\Temp\Log\Test1-OUT2.PDF"
044     
045     '▼1.文書プロパティをセットする例
046     sTitle = "■①タイトル"
047     sSubject = "■②サブタイトル"
048     sAuthor(0) = "■③作成者１"
049     sAuthor(1) = "■③作成者２"
050     sKeywords(0) = "■④キーワード１"
051     sKeywords(1) = "■④キーワード２"
052     sRights = "■⑤著作権情報"
053  
054     '▼2.文書プロパティを空にする例
055 '    sTitle = ""                'タイトル
056 '    sSubject = ""              'サブタイトル
057 '    sAuthor(0) = ""            '作成者
058 '    sKeywords(0) = ""          'キーワード
059 '    sRights = ""               '著作権情報
060  
061     '▼3.処理をスキップさせる例
062     '※vbNullCharをセット時はその項目を処理しない
063 '    sTitle = vbNullChar        'タイトル
064 '    sSubject = vbNullChar      'サブタイトル
065 '    sAuthor(0) = vbNullChar    '作成者
066 '    sKeywords(0) = vbNullChar  'キーワード
067 '    sRights = vbNullChar       '著作権情報
068     
069     bRet = PDF_Update_MXP_INFO( _
070             sInputPdf, sOutputPDF, _
071             sTitle, sSubject, sAuthor(), sKeywords(), sRights, _
072             sMessage)
073  
074     MsgBox "終了" & vbCrLf & sMessage, , _
075         IIf(sMessage = "", "正常", "エラー")
076     
077 End Sub
078  
079  
080 '==================================================
081 '
082 ' タイトル: PDFの文書プロパティ(概要)を更新
083 '
084 '   更新するのは「タイトル」、「サブタイトル」、
085 '   「作成者」、「キーワード」、「著作権情報」です。
086 '
087 ' Create  : 2017/03/25
088 ' Update  : 2017/09/09
089 ' Vertion : 1.0
090 '
091 ' 引数1   : sInputPdf As String (IN)
092 '           入力PDFファイルのフルパス
093 ' 引数2   : sOutputPDF As String (IN)
094 '           出力PDFファイルのフルパス
095 ' 引数3   : sTitle As String (IN)
096 '           文書プロパティのタイトル
097 ' 引数4   : sSubject As String (IN)
098 '           文書プロパティのサブタイトル
099 ' 引数5   : sAuthor() As String (IN)
100 '           文書プロパティの作成者　    複数指定可能
101 ' 引数6   : sKeywords() As String (IN)
102 '           文書プロパティのキーワード　複数指定可能
103 ' 引数7   : sRights As String (IN)
104 '           文書プロパティの著作権情報
105 ' 引数8   : sMessage As String (OUT)
106 '           エラー時のメッセージ
107 '
108 ' 戻り値  : True  正常処理
109 '           False エラー有り
110 '               エラーメッセージは第八引数 sMessage にセットされる
111 '
112 ' 備考    : 最初は「CON_DEBUG = True」でテストして下さい。
113 ' URL     : http://pdf-file.nnn2.com/?p=928
114 ' その他  : 著作権等は主張しません。
115 '           上記URLにコメントを頂けると嬉しいです。
116 '
117 '==================================================
118  
119 Public Function PDF_Update_MXP_INFO( _
120     ByVal sInputPdf As String, _
121     ByVal sOutputPDF As String, _
122     ByVal sTitle As String, _
123     ByVal sSubject As String, _
124     ByRef sAuthor() As String, _
125     ByRef sKeywords() As String, _
126     ByVal sRights As String, _
127     ByRef sMessage As String) As Boolean
128     
129     Dim sFileName       As String   '拡張子無しのファイル名
130     Dim sWorkFile(2)    As String   '作業PDFファイル
131     
132     Dim sAuthor_X()     As String   '作成者
133     Dim sKeywords_X()   As String   'キーワード
134     Dim i               As Long     '添字
135     Dim j               As Long     '添字
136  
137     PDF_Update_MXP_INFO = True
138     
139     '入力PDFの拡張子無しのファイル名を取得
140     sFileName = Mid$(sInputPdf, _
141         InStrRev(sInputPdf, "\") + 1, _
142         InStrRev(sInputPdf, ".") - InStrRev(sInputPdf, "\") - 1)
143     
144     'ログ・ファイルの前処理
145     If CON_DEBUG Then
146         Call Degug_log_Init(sFileName)
147         Call Degug_Put_log("In  PDF-File : " & sInputPdf)
148         Call Degug_Put_log("OUT PDF-File : " & sOutputPDF)
149         Call Degug_Put_log( _
150             "■　Info -> XMP　■　区切り文字は(" & CON_KUGIRI & ")")
151     End If
152     
153     '▼前処理
154     Call UpdatePDF_XMP_INFO_INIT
155     sFileName = sFileName & Format(Date, "-yyyymmdd-")
156     If CON_DEBUG Then Call Debug_PDF_Data(sInputPdf)
157     sWorkFile(0) = CON_WORK_FOLDER & sFileName & _
158             Format(Time, "hhmmss") & "-0.pdf"
159     sWorkFile(1) = CON_WORK_FOLDER & sFileName & _
160             Format(Time, "hhmmss") & "-1.pdf"
161     If sAuthor(0) <> vbNullChar And sAuthor(0) <> "" Then
162         sWorkFile(2) = CON_WORK_FOLDER & sFileName & _
163             Format(Time, "hhmmss") & "-2.pdf"
164     Else
165         sWorkFile(2) = sOutputPDF
166     End If
167     
168     '▼PDF内のゴミを取る為に別名で最適化保存する。
169     Call UpdatePDF_SaveAs(sInputPdf, sWorkFile(0), sMsg)
170     
171     If sMsg <> "" Then        'エラー発生
172         PDF_Update_MXP_INFO = False
173         GoTo Skip_PDF_Update_MXP_INFO:
174     End If
175     If CON_DEBUG Then Call Debug_PDF_Data(sWorkFile(0))
176     
177     '▼Infoの更新
178     Call UpdatePDF_INFO(sWorkFile(0), sWorkFile(1), _
179         sTitle, sSubject, sAuthor(), sKeywords(), sRights, sMsg)
180         
181     If sMsg <> "" Then        'エラー発生
182         PDF_Update_MXP_INFO = False
183         GoTo Skip_PDF_Update_MXP_INFO:
184     End If
185     If CON_DEBUG Then Call Debug_PDF_Data(sWorkFile(1))
186     
187     '▼XMPの更新
188     Call UpdatePDF_XMP(sWorkFile(1), sWorkFile(2), _
189         sTitle, sSubject, sAuthor(), sKeywords(), sRights, sMsg)
190         
191     If sMsg <> "" Then        'エラー発生
192         PDF_Update_MXP_INFO = False
193         GoTo Skip_PDF_Update_MXP_INFO:
194     End If
195     If CON_DEBUG Then Call Debug_PDF_Data(sWorkFile(2))
196     
197     If sWorkFile(2) <> sOutputPDF Then
198         '▼XMPの作成者のみ再更新    ※Acrobat不具合の対応？
199         ReDim sAuthor_X(UBound(sAuthor)) As String
200         For i = 0 To UBound(sAuthor)
201             sAuthor_X(i) = sAuthor(i)
202         Next i
203         ReDim sKeywords_X(UBound(sKeywords)) As String
204         For i = 0 To UBound(sKeywords)
205             sKeywords_X(i) = vbNullChar
206         Next i
207         
208         Call UpdatePDF_XMP(sWorkFile(2), sOutputPDF, _
209             vbNullChar, vbNullChar, _
210             sAuthor_X(), sKeywords_X(), vbNullChar, sMsg)
211             
212         If sMsg <> "" Then        'エラー発生
213             PDF_Update_MXP_INFO = False
214             GoTo Skip_PDF_Update_MXP_INFO:
215         End If
216         If CON_DEBUG Then Call Debug_PDF_Data(sOutputPDF)
217     End If
218     
219 Skip_PDF_Update_MXP_INFO:
220     If CON_DEBUG Then Call Degug_Put_log("■終了")
221     
222     If CON_DEBUG Then Stop  '一時停止
223 On Error Resume Next
224     '作業ファイルの削除
225     Kill sWorkFile(0)
226     Kill sWorkFile(1)
227     If sWorkFile(2) <> sOutputPDF Then Kill sWorkFile(2)
228 End Function
229  
230  
231 '--------------------------------------------------
232 '   変数の初期化
233 '--------------------------------------------------
234  
235 Private Sub UpdatePDF_XMP_INFO_INIT()
236     
237     'XMPの要素名をセット
238     'タイトル
239     sXml(0, 0) = "dc:title"
240     sXml(0, 1) = "rdf:Alt"
241     sXml(0, 2) = "rdf:li"
242     sXml(0, 3) = "xml:lang=""x-default"""
243     
244     'サブタイトル
245     sXml(1, 0) = "dc:description"
246     sXml(1, 1) = "rdf:Alt"
247     sXml(1, 2) = "rdf:li"
248     sXml(1, 3) = "xml:lang=""x-default"""
249     
250     '作成者
251     sXml(2, 0) = "dc:creator"
252     sXml(2, 1) = "rdf:Seq"
253     sXml(2, 2) = "rdf:li"       '複数有り
254     sXml(2, 3) = ""
255     
256     'キーワード
257     sXml(3, 0) = "dc:subject"
258     sXml(3, 1) = "rdf:Bag"
259     sXml(3, 2) = "rdf:li"       '複数有り
260     sXml(3, 3) = ""
261     
262     '著作権情報
263     sXml(4, 0) = "dc:rights"
264     sXml(4, 1) = "rdf:Alt"
265     sXml(4, 2) = "rdf:li"
266     sXml(4, 3) = "xml:lang=""x-default"""
267     
268     '初期化
269     sMsg = ""
270     
271 End Sub
272  
273 '--------------------------------------------------
274 '   PDFファイルを最適化して別名保存
275 '--------------------------------------------------
276  
277 Private Sub UpdatePDF_SaveAs( _
278     ByVal sInputPdf As String, _
279     ByRef sOutputPDF As String, _
280     ByRef sMsg As String)
281  
282     Dim objAcroPDDoc    As New Acrobat.AcroPDDoc
283  
284     'PDFのオープン
285     lRet = objAcroPDDoc.Open(sInputPdf)
286     If lRet = 0 Then
287         sMsg = sInputPdf & vbCrLf & _
288             "1.PDFファイルがオープン出来なかった。"
289         If CON_DEBUG Then Call Degug_Put_log(sMsg)
290         Exit Sub
291     End If
292     
293     '①　最適化で別名保存。
294     '別名でPDFファイルを保存する
295     lRet = objAcroPDDoc.Save _
296         (PDSaveFull + PDSaveLinearized + _
297          PDSaveCollectGarbage, _
298          sOutputPDF)
299     If lRet = 0 Then
300         sMsg = sOutputPDF & vbCrLf & _
301             "2.PDFファイルが保存出来なかった。"
302         If CON_DEBUG Then Call Degug_Put_log(sMsg)
303         Exit Sub
304     End If
305     
306     objAcroPDDoc.Close
307     Set objAcroPDDoc = Nothing
308     
309 End Sub
310  
311 '--------------------------------------------------
312 '   Infoの更新
313 '
314 '--------------------------------------------------
315  
316 Private Sub UpdatePDF_INFO( _
317     ByVal sInputPdf As String, _
318     ByRef sOutputPDF As String, _
319     ByVal sTitle As String, _
320     ByVal sSubject As String, _
321     ByRef sAuthor() As String, _
322     ByRef sKeywords() As String, _
323     ByVal sRights As String, _
324     ByRef sMsg As String)
325     
326     Dim objAcroAVDoc    As New Acrobat.AcroAVDoc
327     Dim objAcroPDDoc    As New Acrobat.AcroPDDoc
328     Dim sInfo           As String
329     Dim i               As Long
330     Dim j               As Long
331  
332     If CON_DEBUG Then Call Degug_Put_log("■Info情報の更新■" & vbCrLf)
333     
334     objAcroAVDoc.Close 1  '※エラー回避ロジック
335     'PDFのオープン
336     lRet = objAcroAVDoc.Open(sInputPdf, "")
337     If lRet = 0 Then
338         sMsg = sInputPdf & vbCrLf & _
339             "[UpdatePDF_INFO].PDFファイルがオープン出来なかった。"
340         If CON_DEBUG Then Call Degug_Put_log(sMsg)
341         GoTo End_UpdatePDF_INFO:
342     End If
343     
344     msDebugMsg = ""
345     
346     '文書ディクショナリ(Info)の更新
347     With objAcroAVDoc.GetPDDoc.GetJSObject
348         'タイトル
349         If sTitle <> vbNullChar Then
350             msDebugMsg = "title(B):" & .info.Title & vbCrLf
351             .info.Title = sTitle
352             msDebugMsg = msDebugMsg & "title(A):" & .info.Title _
353                 & vbCrLf
354         End If
355         'サブタイトル
356         If sSubject <> vbNullChar Then
357             msDebugMsg = msDebugMsg & "Subject(B):" & .info.Subject _
358                 & vbCrLf
359             .info.Subject = sSubject
360             msDebugMsg = msDebugMsg & "Subject(A):" & .info.Subject _
361                 & vbCrLf
362         End If
363         '作成者
364         If sAuthor(0) <> vbNullChar Then
365             msDebugMsg = msDebugMsg & "Author(B):" & .info.Author _
366                 & vbCrLf
367             sInfo = sAuthor(0)
368             For j = 1 To UBound(sAuthor)
369                 If Not (sAuthor(j) = "" Or _
370                         sAuthor(j) = vbNullString) Then
371                     sInfo = sInfo & CON_KUGIRI & sAuthor(j)
372                 End If
373             Next j
374             .info.Author = sInfo
375             msDebugMsg = msDebugMsg & "Author(A):" & .info.Author _
376                 & vbCrLf
377         End If
378         'キーワード
379         If sKeywords(0) <> vbNullChar Then
380             msDebugMsg = msDebugMsg & "Keywords(B):" & .info.Keywords _
381                 & vbCrLf
382             sInfo = sKeywords(0)
383             For j = 1 To UBound(sKeywords)
384                 If Not (sKeywords(j) = "" Or _
385                         sKeywords(j) = vbNullString) Then
386                     sInfo = sInfo & CON_KUGIRI & sKeywords(j)
387                 End If
388             Next j
389             .info.Keywords = sInfo
390             msDebugMsg = msDebugMsg & "Keywords(A):" & .info.Keywords _
391                 & vbCrLf
392         End If
393         '著作権情報
394         'サブタイトル
395         If sRights <> vbNullChar Then
396             msDebugMsg = msDebugMsg & "Rights(B):" & .info.Rights _
397                 & vbCrLf
398             .info.Rights = sRights
399             msDebugMsg = msDebugMsg & "Rights(A):" & .info.Rights _
400                 & vbCrLf
401         End If
402  
403     End With
404     
405     If CON_DEBUG Then Call Degug_Put_log(msDebugMsg)
406     
407     '別名でPDFファイルを保存する
408     Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
409     lRet = objAcroPDDoc.Save _
410         (PDSaveFull + PDSaveLinearized + _
411          PDSaveCollectGarbage, _
412          sOutputPDF)
413     If lRet = 0 Then
414         sMsg = sOutputPDF & vbCrLf & _
415             "[UpdatePDF_INFO].PDFファイルが保存出来なかった。"
416         If CON_DEBUG Then Call Degug_Put_log(sMsg)
417         GoTo End_UpdatePDF_INFO:
418     End If
419     
420 End_UpdatePDF_INFO:
421     objAcroAVDoc.Close 1   '保存しないで閉じる
422     objAcroPDDoc.Close
423     Set objAcroAVDoc = Nothing
424     Set objAcroPDDoc = Nothing
425     
426 End Sub
427  
428 '--------------------------------------------------
429 '   メタデータ・XMP(Xml)の更新
430 '
431 '--------------------------------------------------
432  
433 Private Sub UpdatePDF_XMP( _
434     ByVal sInputPdf As String, _
435     ByRef sOutputPDF As String, _
436     ByVal sTitle As String, _
437     ByVal sSubject As String, _
438     ByRef sAuthor() As String, _
439     ByRef sKeywords() As String, _
440     ByVal sRights As String, _
441     ByRef sMsg As String)
442     
443     Dim objAcroAVDoc    As New Acrobat.AcroAVDoc
444     Dim objAcroPDDoc    As New Acrobat.AcroPDDoc
445     Dim sMetaData       As String
446     Dim sData           As String
447     Dim sMetaOut        As String
448     Dim sReplaceData    As String
449     Dim sTestData1      As String
450     Dim x1              As Long
451     Dim x2              As Long
452     Dim sInfo           As String
453     Dim i               As Long
454     Dim j               As Long
455     
456     If CON_DEBUG Then Call Degug_Put_log("■XMP 情報の更新■")
457     
458     objAcroAVDoc.Close 1   '※エラー回避ロジック
459     'PDFのオープン
460     lRet = objAcroAVDoc.Open(sInputPdf, "")
461     If lRet = 0 Then
462         sMsg = sInputPdf & vbCrLf & _
463             "UpdatePDF_XMP:PDFファイルがオープン出来なかった。"
464         If CON_DEBUG Then Call Degug_Put_log(sMsg)
465         GoTo End_UpdatePDF_XMP:
466     End If
467     
468     'メタデータの取得
469     With objAcroAVDoc.GetPDDoc.GetJSObject
470         sMetaData = .metadata
471     End With
472     
473     '登録又は置き換えるメタデータを事前に作成する
474     For i = 0 To UBound(sXml, 1)
475         If i = 0 And (sTitle = vbNullChar Or sTitle = "") _
476             Then GoTo Skip_Next1:
477         If i = 1 And (sSubject = vbNullChar Or sSubject = "") _
478             Then GoTo Skip_Next1:
479         If i = 2 And (sAuthor(0) = vbNullChar Or sAuthor(0) = "") _
480             Then GoTo Skip_Next1:
481         If i = 3 And (sKeywords(0) = vbNullChar Or sKeywords(0) = "") _
482             Then GoTo Skip_Next1:
483         If i = 4 And (sRights = vbNullChar Or sRights = "") _
484             Then GoTo Skip_Next1:
485         
486         sMetaOut = "<" & sXml(i, 0) & ">" & vbCrLf
487         sMetaOut = sMetaOut & "<" & sXml(i, 1) & ">" & vbCrLf
488         If (i = 0) Or (i = 1) Or (i = 4) Then
489             '配列無し
490             sMetaOut = sMetaOut & _
491                 "<" & sXml(i, 2) & " " & sXml(i, 3) & ">"
492             Select Case i
493             Case 0: sMetaOut = sMetaOut & sTitle
494             Case 1: sMetaOut = sMetaOut & sSubject
495             Case 4: sMetaOut = sMetaOut & sRights
496             End Select
497             sMetaOut = sMetaOut & "</" & sXml(i, 2) & ">" & vbCrLf
498         Else
499             '配列有り
500             Select Case i
501             Case 2
502                 For j = 0 To UBound(sAuthor)
503                     If sAuthor(j) <> "" Then
504                         sMetaOut = sMetaOut & _
505                             "<" & sXml(i, 2) & ">" & sAuthor(j) & _
506                            "</" & sXml(i, 2) & ">" & vbCrLf
507                     End If
508                 Next j
509             Case 3
510                 For j = 0 To UBound(sKeywords)
511                     If sKeywords(j) <> "" Then
512                         sMetaOut = sMetaOut & _
513                             "<" & sXml(i, 2) & ">" & sKeywords(j) & _
514                            "</" & sXml(i, 2) & ">" & vbCrLf
515                     End If
516                 Next j
517             End Select
518         End If
519         sMetaOut = sMetaOut & "</" & sXml(i, 1) & ">" & vbCrLf
520         sMetaOut = sMetaOut & "</" & sXml(i, 0) & ">"
521         
522         'メタデータの更新
523         x1 = InStr(sMetaData, "<" & sXml(i, 0) & ">")
524         x2 = InStr(x1 + _
525             Len(sXml(i, 0)), sMetaData, "</" & sXml(i, 0) & ">")
526         If x1 = 0 Then
527             '存在しないので追加する
528             sTestData1 = Replace(sMetaData, CON_LAST_TAG, _
529                 sMetaOut & vbCrLf & CON_LAST_TAG)
530         Else
531             '存在するので置き換える。
532             sReplaceData = Mid$(sMetaData, x1, _
533                 (x2 + Len("</" & sXml(i, 0) & ">")) - x1)
534             sTestData1 = Replace(sMetaData, sReplaceData, sMetaOut)
535         End If
536         
537         sMetaData = sTestData1
538 Skip_Next1:
539     Next i
540     
541     '削除する場合
542     For i = 0 To UBound(sXml, 1)
543         If i = 0 And sTitle = "" Then GoTo Skip_Next2_Update:
544         If i = 1 And sSubject = "" Then GoTo Skip_Next2_Update:
545         If i = 2 And sAuthor(0) = "" Then GoTo Skip_Next2_Update:
546         If i = 3 And sKeywords(0) = "" Then GoTo Skip_Next2_Update:
547         If i = 4 And sRights = "" Then GoTo Skip_Next2_Update:
548         GoTo Skip_Next2
549         
550 Skip_Next2_Update:
551         'メタデータの更新
552         x1 = InStr(sMetaData, "<" & sXml(i, 0) & ">")
553         x2 = InStr(x1 + Len(sXml(i, 0)), sMetaData, "</" & sXml(i, 0) & ">")
554         If x1 <> 0 Then
555             '存在するので削除する。
556             sReplaceData = Mid$(sMetaData, x1, (x2 + Len("</" & sXml(i, 0) & ">")) - x1)
557             sTestData1 = Replace(sMetaData, sReplaceData, "")
558         End If
559         
560         sMetaData = sTestData1
561 Skip_Next2:
562     Next i
563     
564     '※今回は以下の処理が不要になりましたが改造時の為に残す
565 '    Const CON_KEYWORDS = "pdf:Keywords="""
566 '    If sKeywords(0) <> vbNullChar Then
567 '        If sKeywords(0) = "" Then
568 '            '削除処理
569 '            x1 = InStr(sMetaData, CON_KEYWORDS)
570 '            x2 = InStr(x1 + Len(CON_KEYWORDS), sMetaData, """")
571 '            If x1 <> 0 Then
572 '                '存在するので削除する。
573 '                sReplaceData = Mid$(sMetaData, x1, _
574 '                    (x2 + Len(CON_KEYWORDS)) - x1)
575 '                If CON_DEBUG Then Debug.Print _
576 '                    "sReplaceData(削除)=" & vbCrLf & sReplaceData
577 '                sTestData1 = Replace(sMetaData, sReplaceData, "")
578 '            End If
579 '        Else
580 '            '追加or更新の処理
581 '            sMetaOut = sKeywords(0)
582 '            For j = 1 To UBound(sKeywords)
583 '                If Not (sKeywords(j) = "" Or _
584 '                        sKeywords(j) = vbNullString) Then
585 '                    sMetaOut = sMetaOut & ";" & sKeywords(j)
586 '                End If
587 '            Next j
588 '            sMetaOut = CON_KEYWORDS & sMetaOut & """"
589 '
590 '            x1 = InStr(sMetaData, CON_KEYWORDS)
591 '            x2 = InStr(x1 + Len(CON_KEYWORDS), sMetaData, """")
592 '            If x1 = 0 Then
593 '                '存在しないので追加する
594 '                '※[xmpMM:DocumentID=]の前に入れる
595 '                sTestData1 = Replace(sMetaData, "xmpMM:DocumentID=", _
596 '                    sMetaOut & vbCrLf & "xmpMM:DocumentID=")
597 '                sMetaData = sTestData1
598 '            Else
599 '                '存在するので更新する
600 '                sReplaceData = Mid$(sMetaData, x1, (x2 - x1 + 1))
601 '                sTestData1 = Replace(sMetaData, sReplaceData, sMetaOut)
602 '                sMetaData = sTestData1
603 '            End If
604 '            If CON_DEBUG Then Debug.Print _
605 '                "▼Keywords▼" & vbCrLf & sTestData1
606 '        End If
607 '    End If
608     
609     If CON_DEBUG Then _
610         Call Degug_Put_log("編集後のsMetaDataの値=" & vbCrLf & sMetaData)
611     
612     'XMPデータの更新
613     With objAcroAVDoc.GetPDDoc.GetJSObject
614         .metadata = sMetaData
615     End With
616     
617     '別名でPDFファイルを最適化・保存する
618     Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
619     lRet = objAcroPDDoc.Save _
620         (PDSaveFull + PDSaveLinearized + _
621          PDSaveCollectGarbage, _
622          sOutputPDF)
623     If lRet = 0 Then
624         sMsg = sOutputPDF & vbCrLf & _
625             "UpdatePDF_XMP:PDFファイルが保存出来なかった。"
626         If CON_DEBUG Then Call Degug_Put_log(sMsg)
627         GoTo End_UpdatePDF_XMP:
628     End If
629  
630 End_UpdatePDF_XMP:
631     objAcroAVDoc.Close 1  '保存しないで閉じる
632     objAcroPDDoc.Close
633     Set objAcroAVDoc = Nothing
634     Set objAcroPDDoc = Nothing
635     
636 End Sub
637  
638 '**************************************************
639 '
640 '   LOG の出力 : デバッグ＆確認用
641 '
642 '       テスト完了後はCON_DEBUG = Falseにするか、
643 '       これ以降を削除してください。
644 '
645 '**************************************************
646  
647 Private Sub Debug_PDF_Data(sInputPdf As String)
648  
649     Dim objAcroAVDocX  As New Acrobat.AcroAVDoc
650     Dim lRet            As Long
651     Dim sDebug          As String
652     
653     objAcroAVDocX.Close 1  '※エラー回避ロジック
654     lRet = objAcroAVDocX.Open(sInputPdf, "")
655     If lRet = 0 Then
656         msDebugMsg = sInputPdf & vbCrLf & _
657             "Debug_PDF_DataP:PDFファイルが保存出来なかった。"
658         Call Degug_Put_log(msDebugMsg)
659         Exit Sub
660     End If
661     sDebug = "▼Input-PDF:" & sInputPdf & vbCrLf
662     
663     With objAcroAVDocX.GetPDDoc.GetJSObject
664         sDebug = sDebug & "MetaData(x)=" & vbCrLf & .metadata & vbCrLf
665     
666         '文書ディクショナリ(Info)の情報
667         'タイトル
668         sDebug = sDebug & "title(x):" & .info.Title & vbCrLf
669         'サブタイトル
670         sDebug = sDebug & "Subject(x):" & .info.Subject & vbCrLf
671         '作成者
672         sDebug = sDebug & "Author(x):" & .info.Author & vbCrLf
673         'キーワード
674         sDebug = sDebug & "Keywords(x):" & .info.Keywords & vbCrLf
675         '著作権情報
676         sDebug = sDebug & "Rights(x):" & .info.Rights & vbCrLf
677     End With
678     
679     Call Degug_Put_log(sDebug)  'LOGファイルへ出力
680     
681     objAcroAVDocX.Close 1   '保存しないで閉じる
682     Set objAcroAVDocX = Nothing
683 End Sub
684  
685 '   前処理
686  
687 Private Sub Degug_log_Init( _
688     ByVal sInFileName As String)
689     
690     mlDebugLogFileNo = FreeFile
691     msDebugLogFilePath = CON_WORK_FOLDER & sInFileName & "-log-" & _
692         Format(Date, "yyyymmdd-") & Format(Time, "hhmmss") & ".txt"
693     msDebugLogCnt = 0
694 End Sub
695  
696 '   LOGファイルへ出力
697  
698 Private Sub Degug_Put_log( _
699     ByVal sDeug As String)
700  
701     msDebugLogCnt = msDebugLogCnt + 1
702     Open msDebugLogFilePath For Append As #mlDebugLogFileNo
703     Print #mlDebugLogFileNo, _
704         "(" & msDebugLogCnt & ") " & _
705         Format(Date, "yyyy/mm/dd") & _
706         Format(Time, " hh:mm:ss") & _
707         vbCrLf & sDeug & vbCrLf
708     Close #mlDebugLogFileNo
709  
710 End Sub
711

　Highlight：プログラミング言語のソースコードを構文で色分け (GUI編)
　

結果

上記サンプルの実行結果です。

Source file

001 <x:xmpmeta xmlns:x="adobe:ns:meta/" x:xmptk="Adobe XMP Core 5.4-c005 78.147326, 2012/08/23-13:03:03        ">
002  <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#">
003   <rdf:Description rdf:about=""
004     xmlns:xmp="http://ns.adobe.com/xap/1.0/"
005     xmlns:dc="http://purl.org/dc/elements/1.1/"
006     xmlns:pdf="http://ns.adobe.com/pdf/1.3/"
007     xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/"
008     xmlns:pdfx="http://ns.adobe.com/pdfx/1.3/"
009    xmp:CreateDate="1996-11-30T13:07:53Z"
010    xmp:CreatorTool="FrameMaker 5.1"
011    xmp:ModifyDate="2017-03-25T17:36:56+09:00"
012    xmp:MetadataDate="2017-03-25T17:36:56+09:00"
013    dc:format="application/pdf"
014    pdf:Keywords="■④キーワード１,■④キーワード２"
015    pdf:Producer="Acrobat Distiller 3.0 for Power Macintosh"
016    xmpMM:DocumentID="uuid:********-****-****-****-************"
017    xmpMM:InstanceID="uuid:********-****-****-****-************"
018    pdfx:Rights="■⑤著作権情報">
019    <dc:description>
020     <rdf:Alt>
021      <rdf:li xml:lang="x-default">■②サブタイトル</rdf:li>
022     </rdf:Alt>
023    </dc:description>
024    <dc:creator>
025     <rdf:Seq>
026      <rdf:li>■③作成者１</rdf:li>
027      <rdf:li>■③作成者２</rdf:li>
028     </rdf:Seq>
029    </dc:creator>
030    <dc:title>
031     <rdf:Alt>
032      <rdf:li xml:lang="x-default">■①タイトル</rdf:li>
033     </rdf:Alt>
034    </dc:title>
035    <dc:subject>
036     <rdf:Bag>
037      <rdf:li>■④キーワード１</rdf:li>
038      <rdf:li>■④キーワード２</rdf:li>
039     </rdf:Bag>
040    </dc:subject>
041    <dc:rights>
042     <rdf:Alt>
043      <rdf:li xml:lang="x-default">■⑤著作権情報</rdf:li>
044     </rdf:Alt>
045    </dc:rights>
046   </rdf:Description>
047  </rdf:RDF>
048 </x:xmpmeta>

　Highlight：プログラミング言語のソースコードを構文で色分け (GUI編)
　

但し、残念な事にOLEのInfo内容で作成者は１番目しかセットされませんでした。以下はログファイルからの結果です。

Source file

title(x):■①タイトル
Subject(x):■②サブタイトル
Author(x):■③作成者１
Keywords(x):■④キーワード１,■④キーワード２
Rights(x):■⑤著作権情報

Author(x)は下記が正解です。本当は以下の様にならないと駄目なハズ。
Author(x):■③作成者１,■③作成者２

既知の問題

文書プロパティの作成者を配列で複数指定してもGetInfo の結果は１つ目しか返されません。これに対する逃げ手は現時点(2017/3/25)では見つかっていません。
文書プロパティの作成者とキーワードの区切りは画面上ではカンマ「 , 」やセミコロン「 ; 」で表示されます。更に前後をダブルクオーテーションで表示される場合が有ります。

「XMPの結果」を今は最優先とし、上記の「既知の問題」に関しては余力が出来た時に再検討＆再調査とします。

備考

当関数を改造すれば他のPDFのプロパティ項目も変更可能になると予測しています。しかし、その為にはXMPの知識が必要になります。よってXMPの扱いがよく判らない人は、コメントを頂ければ出来る範囲でご助言いたします。
XMPはXMLファイルと同じなのでXMLパーサーを使ってVBAで処理をするのが本来の形です。しかしこのXMLの変形型のXMPをXMLパーサーで扱うのは実際は容易ではなかったです。よってVBAの文字列関数を駆使して処理をしました。
XML内の以下の行は編集しなくても関数内のXML更新で自動的にOLE更新されます。一応、将来的な改造用に関数には更新ロジックをコメントで残してあります。
- df:Keywords="■④キーワード１,■④キーワード２"
- pdfx:Rights="■⑤著作権情報"

参考

文書プロパティを構成するメタデータと文書情報ディクショナリーについて。
- PDF構文 (PDF Syntax ISO 32000-1)
- XMP PDF埋め込みメタデータ
- Adobe：Acrobat ヘルプ／PDF のプロパティとメタデータ
- Adobe：XMP メタデータ
- Adobe：XMP メタデータ
- ~~Adobe：Importing Metadata into PDF Documents (英語)~~
OLEからMetaDataとInfoの操作について。
JavaScript for Acrobat API Reference Adobe Acrobat SDK バージョン 8.0
XMPに関してダウンロードできるPDF文書とサンプル。
- Adobe XMP Developer Center (英語)　サイト
  上記のリンク先から　Agree and download XMP Toolkit SDK CC-2016.7 (ZIP, 38.7 MB)　をダウンロード。
  英語ですがこの ZIP ファイルは必ず入手して下さい。
  非常に参考になります。

動作確認環境

Windows 10 Pro 64bit + Acrobat Pro XI + Excel 2007

< 関数へ戻る >

＜管理者の技術メモ＞

これ以降はサイト管理人の技術関連メモです。見なくて結構です。

メタデータ（XMP）と文書情報ディクショナリー（Info）がどのように関係して連携？しているのかが不明。PDFの内部を追ってみたが分からなかった。ココは非公開的な内容なのかもしれない。
テスト結果から予測すると、複数指定可能なプロパティにはバグっぽい臭いが、ヤヤする。と言えども、それをカバーする関数処理が出来なかった事が悔しい。
PDFのXMPに関する日本語の説明書（PDF等）は存在しなかった。
英語版のXMPの説明書はPDF専門の内容では無いが、かなり参考になった。説明内にはXMPのサンプルも豊富に入っている。タブン、これが唯一のXMPに関する最良の説明書と思われる。
他にもPDFのXMPデータを出力するコマンドラインツールは存在するが、これを更に読み込んでXMPを更新するツールは存在しない。
PDFtkに似たような機能が合ったが、正常に機能しなかった。
XMPのインポートとエクスポートの両方が出来るのは、調べた限りではAcrobatアプリ本体のみ。
但し、当関数を参考にすればXMPのインポートとエクスポートを簡単に行うことが出来ることが分かる。
他のXMP要素名はココに書いてある内容かな？　このXMPSpecificationPart1.pdf ファイルは上記のダウンロードZIPファイルに含まれている。
XMPの＜rdf:Bag＞＜rdf:Seq＞＜rdf:Alt ＞の説明に関してはココ<の7.7 Array valued XMP properties>に有る。
テストでは別の要素名に書き換えても影響しないみたいで結果は同じだった。
VBAソース内の＜と＞文字はHTMLコードと一部が見なされて、誤変換されたり、強制削除されてしまう。後々のメンテが面倒なので貼り付ける時は＜、＞文字は全角文字に一括変換してからWEB公開する。サンプルを利用する側に少し手間が掛かるが、メンテナンスする側の方が何倍も大変なので、ハイ。
半角に戻す注意事項も忘れずにシツコイぐらい書いて置きました。
- IF 命令内の比較演算子＜、＞文字は問題無い。
- ”＜” 、”＞” 、”＜／” が誤認識、又は強制排除（削除）される。

< 関数へ戻る >

コメントを残す

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

コメント ※

名前 ※

メール ※

サイト

CAPTCHA

上に表示された文字を入力してください。

★　文章での質問は難しいですよネ。でも、早く解決して、家に帰りたい。

SAMURAI Plugin

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

OS名バージョン
Acrobat バージョン
ツール(Excel等) バージョン

コメントにサンプルコードを入れる時はコードを全て全角文字列にしてください。コチラで半角に戻します。それでもエラーが回避できない時はコメント下さい。個別に対処します。

お仕事で当サイトを見ている方へ
考え込んだら、ご質問下さい。
一緒に解決策を考えましょう。

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

概要

機能

注意事項

形式

引数

戻り値

サンプル

結果

既知の問題

備考

参考

動作確認環境

＜管理者の技術メモ＞

コメントを残す

VBA(Excel)からAcrobat経由でPDFをプログラミング操作(OLE:IAC)する