Excel・Word・Powerpointファイルのドキュメント情報を削除するマクロ

Remove Document Information from a Excel/Word/Powerpoint File Using Excel VBA


 

はじめに

このマクロは、ファイルのドキュメント情報を削除するマクロと、ファイルのドキュメント情報の一覧表を作成するマクロから成ります。
ファイルのドキュメント情報とは、ファイルの作成者名、会社名、管理者名などのファイルに関する情報のことです。
これらの情報は社内限りでファイルを取り扱う場合にはなんら問題にはならないでしょう。
しかし、ファイルを社外に送る場合には問題になるケースもありえます。
このマクロはそんな問題を解決するために、ファイルのドキュメント情報を削除してしまおうというマクロです。

・動作は無保証です。
・エクセルで動くマクロです。
・シート上のボタンを押すだけで、ファイルのドキュメント情報を削除したり、その一覧表を作成したりできます。
・説明の簡略化のために最低限のエラー処理しか施していません。必要なエラー処理があれば、ご自分で実装なさってください。
・他のページと内容の重複がある場合があります。あらかじめご了承ください。
・動作確認は、Windows 10 + Excel 2016、Windows 7 + Excel 2010でおこなっています。
・このマクロを保存するブックのドキュメント情報は自動削除できませんので、このブックだけは手動でドキュメント情報を削除してください。
・参照設定は、「Microsoft Word 16.0 Object Library」「Microsoft Powerpoint 16.0 Object Library」に対して参照設定してください(Excel 2016の場合)。

・ファイルはここからダウンロードしてください。

 

ファイルのドキュメント情報を削除するマクロのソースコード

Option Explicit

Public Sub S_RemoveDocInfo_Main()
  With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "ファイルのドキュメント情報を削除"
    .InitialView = msoFileDialogViewList
    .AllowMultiSelect = False
    .ButtonName = "選択(&S)"
    '.InitialFileName = "C:\Users\amacoda\Documents\Excel ファイル\"

    With .Filters
      .Clear
      .Add "Office ファイル", _
           "*.xls; *.xlsx; *.xlsm; " & _
           "*.doc; *.docx; *.docm; " & _
           "*.ppt; *.pptx; *.pptm", 1
      .Add "Excel ファイル", "*.xls; *.xlsx; *.xlsm", 2
      .Add "Word ファイル", "*.doc; *.docx; *.docm", 3
      .Add "Powerpoint ファイル", "*.ppt; *.pptx; *.pptm", 4
    End With

    Select Case .Show
      Case True
        Dim File As String: File = .SelectedItems(1)
      Case False
        MsgBox "キャンセルが押されたので終了します。", _
               vbOKOnly + vbExclamation, "プログラムの終了"
        Exit Sub
    End Select
  End With

  If File = ThisWorkbook.FullName Then
    MsgBox "このブックのドキュメント情報は自動では削除できません。" & _
           "手動で削除してください。", vbOKOnly + vbInformation
    Exit Sub
  End If

  Dim Extension As String
  Extension = LCase(Right(File, Len(File) - InStrRev(File, ".")))

  Switch = True

  Dim Flag As Boolean
  Select Case Extension
    Case "xls", "xlsx", "xlsm"
      Flag = F_RemoveDocInfo_Excel(File)
    Case "doc", "docx", "docm"
      Flag = F_RemoveDocInfo_Word(File)
    Case "ppt", "pptx", "pptm"
      Flag = F_RemoveDocInfo_Powerpoint(File)
  End Select

  Switch = False

  If Flag = True Then
    MsgBox "ドキュメント情報削除完了", vbOKOnly + vbInformation
  End If
End Sub

Private Property Let Switch(ByVal Flag As Boolean)
  With Application
    .ScreenUpdating = Not Flag
    .DisplayStatusBar = Not Flag
    .Calculation = _
      IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
    .EnableEvents = Not Flag
    .PrintCommunication = Not Flag
    .DisplayAlerts = Not Flag
  End With
End Property

 

ファイルのドキュメント情報を削除するマクロの解説

このマクロは、ボタンを押して、ドキュメント情報を削除したいファイルを1つ選ぶと、自動的にファイルを開き、ドキュメント情報が削除され、上書き保存され、ファイルを閉じるというマクロです。

Application.FileDialog プロパティ

With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "ファイルのドキュメント情報を削除"
  .InitialView = msoFileDialogViewList
  .AllowMultiSelect = False
  .ButtonName = "選択(&S)"
  '.InitialFileName = "C:\Users\amacoda\Documents\Excel ファイル\"

  With .Filters
    .Clear
    .Add "Office ファイル", _
         "*.xls; *.xlsx; *.xlsm; " & _
         "*.doc; *.docx; *.docm; " & _
         "*.ppt; *.pptx; *.pptm", 1
    .Add "Excel ファイル", "*.xls; *.xlsx; *.xlsm", 2
    .Add "Word ファイル", "*.doc; *.docx; *.docm", 3
    .Add "Powerpoint ファイル", "*.ppt; *.pptx; *.pptm", 4
  End With

  Select Case .Show
    Case True
      Dim File As String: File = .SelectedItems(1)
    Case False
      MsgBox "キャンセルが押されたので終了します。", _
             vbOKOnly + vbExclamation, "プログラムの終了"
      Exit Sub
  End Select
End With

このファイルダイアログは、「msoFileDialogFilePicker」を引数としていますので、エクセル・ワード・パワポのファイルを1つ開き、そのファイル名を参照します。参照とは、あるファイル名を指定すると、そのファイル名が「SelectedItems」コレクションに追加される、ということです。わたしたちは、それを変数に代入するなどして利用します。むしろ、ある変数にファイル名を格納したいから参照するというほうがわかりやすいかもしれません。

.Title = "ファイルのドキュメント情報を削除"
.InitialView = msoFileDialogViewList
.AllowMultiSelect = False
.ButtonName = "選択(&S)"
'.InitialFileName = "C:\Users\amacoda\Documents\Excel ファイル\"

「Application.FileDialog」プロパティは「FileDialog」オブジェクトを返しますので、その用途はSelectedItemsコレクションにファイル名を追加するだけではありません。
オブジェクトですので、その他に2つのメソッド、12のプロパティを持っています。
その中で、「Title」プロパティは、ダイアログのタイトルを設定できます。設定できるということは取得することもできるということです。
「InitialView」プロパティは、ファイルのダイアログ ボックスでのファイルやフォルダーの初期表示を決定します。ここでは、8つの「MsoFileDialogView」定数の中から「msoFileDialogViewList」を選択しました。この表示のしかたは、エクスプローラでいえば、「表示 -> 一覧」に似ています。
「AllowMultiSelect」プロパティは、複数のファイルを選択できるようにするか、1つのファイルだけを選択できるようにするかを決定します。ここでは、「False」を選択し、1つのファイルだけを選択できるようにします。
「ButtonName」プロパティは、ダイアログボックスの動作設定ボタンに表示されるテキストを表す文字列を設定します。ここでは「選択(&S)」とし、ショートカットキーを表す「(&S)」を付け加えています。この設定で、動作設定ボタンを「Alt + S」というショートカットキーで選択することも可能になります。
ここでは使用しないプロパティ紹介します。「InitialFileName」プロパティがそれです。ダイアログボックスに最初に表示されるファイル名を設定できます。ですが、別の使い方もできます。「C:\Users\amacoda\Documents\Excel ファイル\」のようにファイル名ではなく、「フォルダのパス + \」とすると、特定のファイル名を選択することなく、(後述するファイルフィルタによって設定された)すべてのファイルを表示します。

「Filters」プロパティは、いわゆる「ファイルの絞り込み」に関するプロパティです。ここではエクセル・ワード・パワポの中から選びたい、いや、ここではエクセルのみから選びたい、などという絞り込みに対するニーズに応えます。「Clear」メソッドで以前のフィルタを消去し、「Add」メソッドで新しいフィルタを追加します。フィルタはいくつでも追加できます。

.Add "Office ファイル", _
     "*.xls; *.xlsx; *.xlsm; " & _
     "*.doc; *.docx; *.docm; " & _
     "*.ppt; *.pptx; *.pptm", 1

最初のフィルタは「Office ファイル」としました。エクセル・ワード・パワポの9種類の拡張子のファイルから選択できます。最後の「1」は1番目のフィルタという意味であり、何個もフィルタがある場合に最初に表示されるという意味です。

.Add "Excel ファイル", "*.xls; *.xlsx; *.xlsm", 2

2番目のフィルタはエクセルのファイルです。

.Add "Word ファイル", "*.doc; *.docx; *.docm", 3

3番目のフィルタはワードのファイルです。

.Add "Powerpoint ファイル", "*.ppt; *.pptx; *.pptm", 4

4番目のフィルタはパワポのファイルです。

この画像のように、好きなフィルタを選択して、絞り込みたい範囲を変更します。

Select Case .Show
  Case True
    Dim File As String: File = .SelectedItems(1)
  Case False
    MsgBox "キャンセルが押されたので終了します。", _
           vbOKOnly + vbExclamation, "プログラムの終了"
    Exit Sub
End Select

「Show」メソッドの返り値を、Select Case文を使って分岐しています。
「True」の場合は、アクションボタンを押したという意味(ファイルを選択していないとアクションボタンは押せません)ですので、「SelectedItems」コレクションにファイル名の文字列が追加されます。ここでは、1個のファイル名しか追加できませんので、「SelectedItems(1)」が唯一のファイル名の文字列になります。その文字列を「File」という変数に格納しています。
「False」の場合は、キャンセルボタンを押したという意味ですので、「MsgBox」関数を表示してマクロを終了します。

このブックに関するエラー処理

If File = ThisWorkbook.FullName Then
  MsgBox "このブックのドキュメント情報は自動では削除できません。" & _
         "手動で削除してください。", vbOKOnly + vbInformation
  Exit Sub
End If

ここは、変数「File」に格納されたファイル名のフルパスの文字列が、このマクロが保存されているファイル名のフルパスの文字列と一致したときは、(サブルーチンでの処理方法に合わないので)「MsgBox」関数を表示してマクロを終了します。

拡張子の取得

Dim Extension As String
Extension = LCase(Right(File, Len(File) - InStrRev(File, ".")))

拡張子を取得するのにRight関数を使っています。変数「File」から一番最後のピリオド「.」の右側の部分を取得するのですが、一番最後のピリオドが変数「File」に格納された文字列の左から何番目にあるかを取得するのに「InStrRev」関数を使っています。
「InStrRev」関数は、文字列を後方(右)から検索して、検索された文字列の先頭位置(左から何番目か)を返します。
そして、「Len」関数で得た「File」の文字数から「InStrRev」関数で得た「.」の位置を引いてやると、拡張子の文字数(ここでは「3」か「4」)が得られます。
そうやって得た拡張子の文字数を用いて、「Right」関数で拡張子の文字列を取得します。
最後に「LCase」関数で得られた文字列を小文字に変換します。

「InStrRev」関数は、Excel 2000 VBAから追加された関数ですが、「InStrRev」関数がなかった時代は次のようにプログラミングしていました。

Sub S_Sample()
  Dim myString As String
  myString = "C:\Users\amacoda\Documents\Excel ファイル\boo.xls"

  'myStringの中に「\」が見つからなくなるまでループする
  Do Until InStr(myString, "\") = 0
    Dim myNumber As Long: myNumber = InStr(myString, "\")
    myString = Mid(myString, myNumber + 1)
  Loop

  MsgBox "File Name is " & """" & myString & """"
End Sub

「InStrRev」関数は非常に便利な関数で、私の場合、「InStr関数」よりも「InStrRev」関数のほうが出番が多いです。
というもの、ファイル名のフルパスからこのケースのように拡張子を取得する場合が多いからです。

マクロの高速化・自動化の設定適用

Public Sub S_RemoveDocInfo_Main()

~~~~~~~~~

  Switch = True

~~~~~~~~~

  Switch = False

~~~~~~~~~
End Sub

プロパティプロシージャ「Switch」を呼び出し、「True」を設定することでマクロの高速化・自動化の設定スイッチオン、「False」を設定することでスイッチオフにしています。

 

プロパティプロシージャ「Switch」の解説

Private Property Let Switch(ByVal Flag As Boolean)
  With Application
    .ScreenUpdating = Not Flag
    .DisplayStatusBar = Not Flag
    .Calculation = _
      IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
    .EnableEvents = Not Flag
    .PrintCommunication = Not Flag
    .DisplayAlerts = Not Flag
  End With
End Property

このプロパティプロシージャ「Switch」は「Property Let」なので、オブジェクトでないプロパティに値を設定することができます。
ちなみに「Property Get」は値を取得するための専用のプロシージャ、「Property Set」はオブジェクトまたはバリアント型のプロパティに値を設定することができます。
標準モジュールで利用するプロパティプロシージャは「Property Let」が多いと思います。クラスモジュールと違い、同時に多数のプロパティの値を取得するケースは見出しにくいからです。
「Property Let」のほうは、上記の例のように、同時に多数のプロパティに値を設定したいというケースがありえます。

プロパティプロシージャ「Switch」の作用については、「Switch」に「True]を設定すると「IIf」関数以外のプロパティには「False」が設定され、「IIf」関数では左側の値が設定されます。また、「False」を設定するとプロパティには「True」が設定され、「IIF」関数には右側の値が設定されます。
おおまかにいうと、「True」を設定すると、それぞれの機能をオフにする方向に働き、「False」を設定すると、それぞれの機能をオンにする方向に働きます。

各々のプロパティの解説は以下のページが詳しいでしょう
Excel VBA 高速化アプローチ【プロパティ編】|Dev-Clips

 

ファンクションプロシージャ「F_RemoveDocInfo_Excel」の解説

Private Function F_RemoveDocInfo_Excel _
  (ByVal File As String) As Boolean

  On Error GoTo HandleError

  Dim myWorkbook As Workbook
  Set myWorkbook = Workbooks.Open(Filename:=File)

  With myWorkbook
    .RemoveDocumentInformation xlRDIAll
    '.RemoveDocumentInformation xlRDIDocumentProperties
    '.RemoveDocumentInformation xlRDIRemovePersonalInformation
    '.RemoveDocumentInformation xlRDIPrinterPath

    .RemovePersonalInformation = True
    .Save
    .RemovePersonalInformation = False

    With .BuiltinDocumentProperties
      .Item("Author").Value = " "
      .Item("Company").Value = " "
      .Item("Manager").Value = " "
      .Item("Last Author").Value = " "
    End With

    .Save
    .Close
  End With

  Set myWorkbook = Nothing

  F_RemoveDocInfo_Excel = True

  Exit Function
HandleError:
  Call S_ShowErrorMessage
End Function

このサブプロシージャはエクセルファイルのドキュメント情報を削除します。

On Error ステートメントの解説

  On Error GoTo HandleError
~~~~~~~~~~~~
  Exit Function
HandleError:
  Call S_ShowErrorMessage
End Function

「On Error GoTo HandleError」という命令文で、エラーが発生した際に「HandleError:」行ラベルへとジャンプすることができます。
本マクロでは、「HandleError:」行ラベルの中で「S_ShowErrorMessage」サブルーチンを呼び出します。
1点重要な点は、「HandleError:」行ラベルの前に「Exit Function」という命令文でサブルーチンを抜けることを可能にしておく点です。そうしないと、エラーがいっさい起こらなかった場合でも、「HandleError:」行ラベルの中の命令文が実行されてしまいます。

ドキュメント情報の削除

Dim myWorkbook As Workbook
Set myWorkbook = Workbooks.Open(Filename:=File)

With myWorkbook
  .RemoveDocumentInformation xlRDIAll
  '.RemoveDocumentInformation xlRDIComments
  '.RemoveDocumentInformation xlRDIDocumentProperties
  '.RemoveDocumentInformation xlRDIRemovePersonalInformation
  '.RemoveDocumentInformation xlRDIPrinterPath

  .RemovePersonalInformation = True
  .Save
  .RemovePersonalInformation = False

  With .BuiltinDocumentProperties
    .Item("Author").Value = " "
    .Item("Company").Value = " "
    .Item("Manager").Value = " "
    .Item("Last Author").Value = " "
  End With

  .Save
  .Close
End With

Set myWorkbook = Nothing

結果を先に書きますと、ここではすべての削除できるドキュメント情報を削除し、削除できない項目については「半角スペース” “」を代入することによって見かけ上削除しています。それでは困るという場合は、以下の解説をお読みください。

Dim myWorkbook As Workbook
Set myWorkbook = Workbooks.Open(Filename:=File)

引数で親プロシージャからもらった変数「File」に格納されているファイルのフルパス名の文字列からエクセルのファイルを開いて変数「myWorkbook」に格納します。

.RemoveDocumentInformation xlRDIAll
'.RemoveDocumentInformation xlRDIDocumentProperties
'.RemoveDocumentInformation xlRDIRemovePersonalInformation
'.RemoveDocumentInformation xlRDIPrinterPath

「RemoveDocumentInformation」メソッドでは、「RemoveDocInfoType」オプションに「XlRemoveDocInfoType」列挙体から「xlRDIAll」タイプを指定し、すべてのドキュメント情報を削除します。しかし、この「すべて」が曲者であり、私たちが考える「すべて」は削除されないのです。具体的には「最終更新者」などは削除されません。
そこで対応は2つあります。1つは、あくまでも「すべて」削除することを目指す。2つ目は、削除できない部分はあきらめて削除できる部分だけを削除するというものです。
1つ目の対応としては、ここにあるとおり、「xlRDIAll」タイプを指定し、以下で完全削除を目指すというもの。2つ目の対応としては、コメントにしてありますが、「xlRDIComments」タイプでコメントを、「xlRDIDocumentProperties」タイプでドキュメント情報を、「xlRDIRemovePersonalInformation」タイプで個人情報を、「xlRDIPrinterPath」タイプでプリンターのパスを削除します。ドキュメント情報・個人情報は前述したとおり、一部しか削除されません。
「RemoveDocumentInformation」メソッドで削除できるドキュメント情報は、次のページにあるとおりで、それ以外は削除できません。
XlRemoveDocInfoType 列挙 (Excel)
全部で20種類の情報を削除できます。

.RemovePersonalInformation = True
.Save
.RemovePersonalInformation = False

「RemovePersonalInformation」プロパティは、名前は「RemoveDocumentInformation」メソッドと似ていますが、メソッドではなく、プロパティです。こちらは1つ1つの個人情報を削除するわけではなく、一括で個人情報を削除可能にするか、不可能にするかを決めるプロパティです。「True」を設定すると、削除可能にし、「False」を設定すると、削除不可能にします。
そして、「True」を設定した状態で上書き保存すると個人情報が一括で削除されます。
しかし、これには重大な副作用が発生します。次の画像を見てください。

この画像は、個人情報が一括で削除された後、上書き保存するたびに毎回必ず表示されるダイアログです。毎回です。しかも、必ずです。非常にうっとおしいですね。
これを回避するために、次の命令文で「.RemovePersonalInformation = False」とし、個人情報の削除を不可能に戻すかわりにうっとおしいダイアログを表示しないようにしています。

With .BuiltinDocumentProperties
  .Item("Author").Value = " "
  .Item("Company").Value = " "
  .Item("Manager").Value = " "
  .Item("Last Author").Value = " "
End With

上述の部分で、ドキュメント情報が完全には削除されないという意味のことを書いたのは、ここに出てくる「BuiltinDocumentProperties」プロパティがあるからです。
ここでは、代表的な「Author(作成者)」「Company(会社名)」「Manager(管理者)」「Last Author(最終更新者)」の「Value」プロパティに「半角スペース” “」を代入することで、削除の代わりとしています。本当は「Empty」値を設定することで削除することができるはずなのですが、私の環境ではうまく削除できませんでした。
なお、「Last Author(最終更新者)」だけは「Empty」値を代入しても削除できません。
ここに後述するマクロでリストアップした「BuiltinDocumentProperties」プロパティのすべてのメンバーを示しておきます。
ご自分で必要なメンバーを削除するといいと思います。私は上記の4つで十分と判断しました。

 1 Title                              タイトル
 2 Subject                            サブタイトル
 3 Author                             作成者
 4 Keywords                           キーワード
 5 Comments                           コメント
 6 Template                           テンプレート
 7 Last author                        更新者
 8 Revision number                    改訂番号
 9 Application name                   アプリケーション名
10 Last print date                    印刷日時
11 Creation date                      作成日時
12 Last save time                     更新日時
13 Total editing time                 編集時間
14 Number of pages                    ページ数
15 Number of words                    単語数
16 Number of characters               文字数
17 Security                           セキュリティ
18 Category                           分類
19 Format                             形式
20 Manager                            管理者
21 Company                            会社名
22 Number of bytes                    バイト数
23 Number of lines                    行数
24 Number of paragraphs               段落数
25 Number of slides                   スライドの数
26 Number of notes                    メモの数
27 Number of hidden Slides            非表示スライドの数
28 Number of multimedia clips         マルチメディアクリップの数
29 Hyperlink base                     ハイパーリンクの基点
30 Number of characters (with spaces) 文字数(スペースを含む)
31 Content type                       コンテンツのタイプ
32 Content status                     コンテンツの状態
33 Language                           言語
34 Document version                   バージョン
.Save
.Close

最後に保存して閉じます。

 

ファンクションプロシージャ「F_RemoveDocInfo_Word」のソースコード

Private Function F_RemoveDocInfo_Word _
  (ByVal File As String) As Boolean

  On Error GoTo HandleError

  Dim wdApp As Object
  Set wdApp = CreateObject("Word.Application")
  With wdApp
    .DisplayAlerts = wdAlertsNone
    .Visible = False
  End With

  Dim myDocument As Object
  Set myDocument = wdApp.Documents.Open(Filename:=File)

  With myDocument
    .RemoveDocumentInformation wdRDIAll
    '.RemoveDocumentInformation wdRDIDocumentProperties
    '.RemoveDocumentInformation wdRDIRemovePersonalInformation

    .RemovePersonalInformation = True
    .Save
    .RemovePersonalInformation = False

    With .BuiltinDocumentProperties
      .Item(wdPropertyAuthor).Value = " "
      .Item(wdPropertyCompany).Value = " "
      .Item(wdPropertyManager).Value = " "
      .Item(wdPropertyTemplate).Value = " "
      .Item(wdPropertyLastAuthor).Value = " "
    End With

    .Save
    .Close
  End With

  Set myDocument = Nothing
  wdApp.Quit
  Set wdApp = Nothing

  F_RemoveDocInfo_Word = True

  Exit Function
HandleError:
  Call S_ShowErrorMessage
End Function

内容的には、「F_RemoveDocInfo_Excel」と重複する部分が多いので、重複しない部分のみ解説します。

Wordオブジェクトの取得

Dim wdApp As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
  .DisplayAlerts = wdAlertsNone
  .Visible = False
End With

オブジェクト型の変数「wdApp」を宣言し、「CreateObject」関数で生成したWordアプリケーションへの参照を格納します。
こうして取得した変数「wdApp」に対して、自動化処理をおこないます。
「DisplayAlerts」プロパティには、「False」ではなく「wdAlertsNone」を、「Visible」プロパティには「False」を代入して、確認メッセージとウィンドウ自体を非表示にして処理を自動化します。

ドキュメント情報の削除

Dim myDocument As Object
Set myDocument = wdApp.Documents.Open(Filename:=File)

With myDocument
.RemoveDocumentInformation wdRDIAll
'.RemoveDocumentInformation wdRDIDocumentProperties
'.RemoveDocumentInformation wdRDIRemovePersonalInformation

.RemovePersonalInformation = True
.Save
.RemovePersonalInformation = False

With .BuiltinDocumentProperties
  .Item(wdPropertyAuthor).Value = " "
  .Item(wdPropertyCompany).Value = " "
  .Item(wdPropertyManager).Value = " "
  .Item(wdPropertyLastAuthor).Value = " "
End With

.Save
.Close
End With

オブジェクト型の変数「myDocument」を宣言し、開いたファイルへの参照を格納する場合は、単に「Documents.Open(~)」でも動作しますが、念のため「wdApp.Documents.Open(~)」とします。

 

ファンクションプロシージャ「F_RemoveDocInfo_Powerpoint」のソースコード

Private Function F_RemoveDocInfo_Powerpoint _
  (ByVal File As String) As Boolean

  On Error GoTo HandleError

  Dim ppApp As Object
  Set ppApp = CreateObject("Powerpoint.Application")
  ppApp.DisplayAlerts = ppAlertsNone

  Dim myPresentation As Object
  Set myPresentation = ppApp.Presentations.Open(Filename:=File, _
                                                WithWindow:=msoFalse)
  With myPresentation
    .RemoveDocumentInformation ppRDIAll
    '.RemoveDocumentInformation ppRDIDocumentProperties
    '.RemoveDocumentInformation ppRDIRemovePersonalInformation

    .RemovePersonalInformation = msoTrue
    .Save
    .RemovePersonalInformation = msoFalse

    With .BuiltinDocumentProperties
      .Item("Author").Value = " "
      .Item("Company").Value = " "
      .Item("Manager").Value = " "
      .Item("Last Author").Value = " "
    End With

    .Save
    .Close
  End With

  Set myPresentation = Nothing
  ppApp.Quit
  Set ppApp = Nothing

  F_RemoveDocInfo_Powerpoint = True

  Exit Function
HandleError:
  Call S_ShowErrorMessage
End Function

Private Sub S_ShowErrorMessage()
  MsgBox "エラー番号:" & Err.Number & vbCrLf & _
         "エラー内容:" & Err.Description, _
         vbOKOnly + vbExclamation, "ドキュメント情報削除"
End Sub

ドキュメント情報の削除

Dim myPresentation As Object
Set myPresentation = ppApp.Presentations.Open(Filename:=File, _
                                            WithWindow:=msoFalse)
With myPresentation
.RemoveDocumentInformation ppRDIAll
'.RemoveDocumentInformation ppRDIDocumentProperties
'.RemoveDocumentInformation ppRDIRemovePersonalInformation

.RemovePersonalInformation = msoTrue
.Save
.RemovePersonalInformation = msoFalse

With .BuiltinDocumentProperties
  .Item("Author").Value = " "
  .Item("Company").Value = " "
  .Item("Manager").Value = " "
  .Item("Last Author").Value = " "
End With

.Save
.Close
End With

オブジェクト型の変数「myPresentation」を宣言し、開いたファイルへの参照を格納する場合は、必ず「ppApp.Presentatins.Open(~)」とします。「ppApp」を省略すると動作しません。ここはワードと違うところです。

 

「S_ShowErrorMessage」サブプロシージャのソースコード

Private Sub S_ShowErrorMessage()
  MsgBox "エラー番号:" & Err.Number & vbCrLf & _
         "エラー内容:" & Err.Description, _
         vbOKOnly + vbExclamation, "ドキュメント情報削除"
End Sub

エラーに対応したMsgBox関数を表示するだけのサブプロシージャですが、3回も出てくるので独立したサブプロシージャにしました。こうすると、同じことを3行を3回書いて計9行書くよりも、1行を3回書いて計3行書くだけですみますし、読む側の負担も軽減されます。

 

「S_ListBuiltInDocumentProperties_Main」サブプロシージャのソースコード

Public Sub S_ListBuiltInDocumentProperties_Main()
  With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "ファイルの組み込みドキュメント情報の一覧表作成"
    .InitialView = msoFileDialogViewList
    .AllowMultiSelect = False
    .ButtonName = "選択(&S)"
    '.InitialFileName = "C:\Users\amacoda\Documents\Excel ファイル\"

    With .Filters
      .Clear
      .Add "Office ファイル", _
           "*.xls; *.xlsx; *.xlsm; " & _
           "*.doc; *.docx; *.docm; " & _
           "*.ppt; *.pptx; *.pptm", 1
      .Add "Excel ファイル", "*.xls; *.xlsx; *.xlsm", 2
      .Add "Word ファイル", "*.doc; *.docx; *.docm", 3
      .Add "Powerpoint ファイル", "*.ppt; *.pptx; *.pptm", 4
    End With

    Select Case .Show
      Case True
        Dim File As String: File = .SelectedItems(1)
      Case False
        MsgBox "キャンセルが押されたので終了します。", _
               vbOKOnly + vbExclamation, "プログラムの終了"
        Exit Sub
    End Select
  End With

  Dim Extension As String
  Extension = LCase(Right(File, Len(File) - InStrRev(File, ".")))

  Switch = True

  Select Case Extension
    Case "xls", "xlsx", "xlsm"
      Call S_ListBuiltInDocumentProperties_Excel(File)
    Case "doc", "docx", "docm"
      Call S_ListBuiltInDocumentProperties_Word(File)
    Case "ppt", "pptx", "pptm"
      Call S_ListBuiltInDocumentProperties_Powerpoint(File)
  End Select

  Switch = False

  MsgBox "ファイルの組み込みドキュメント情報の一覧表作成終了!", _
         vbOKOnly + vbInformation
End Sub

Private Property Let Switch(ByVal Flag As Boolean)
  With Application
    .ScreenUpdating = Not Flag
    .DisplayStatusBar = Not Flag
    .Calculation = _
      IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
    .EnableEvents = Not Flag
    .PrintCommunication = Not Flag
    .DisplayAlerts = Not Flag
  End With
End Property

「S_RemoveDocInfo_Main」プロシージャとそっくりのプロシージャです。「使いまわし」ともいいます。このくらいの規模のマクロならこのくらいの冗長性はわかりやすさのために許容範囲だと思います。また、このプロシージャは応用が効くともいえます。
分割するときは、引数を中心に考えます。例えば「Application.FileDialog」の部分と「Select Case」の部分を分割するには、もらう引数はなく、渡す引数はファイル名のフルパスの文字列型なので、ファンクションプロシージャにして、「S_RemoveDocInfo_Main」と「S_ListBuiltInDocumentProperties_Main」で使いまわします。「Switch」プロパティプロシージャも冗長性を回避する場合は使いまわします。

 

「S_ListBuiltInDocumentProperties_Excel」サブプロシージャの解説

Private Sub S_ListBuiltInDocumentProperties_Excel _
  (ByVal File As String)

  Dim myWorkbook As Workbook
  Set myWorkbook = Workbooks.Open(Filename:=File)

  With ThisWorkbook.Worksheets("Excel")
    .Activate
    .Cells.ClearContents

    Dim myRow As String: myRow = 1
    .Cells(myRow, 2).Value = myWorkbook.FullName
    myRow = myRow + 1

    On Error Resume Next

    Dim myDocumentProperty As DocumentProperty
    For Each myDocumentProperty _
      In myWorkbook.BuiltinDocumentProperties

      .Cells(myRow, 1).Value = myRow - 1
      .Cells(myRow, 2).Value = myDocumentProperty.Name
      .Cells(myRow, 3).Value = myDocumentProperty.Value
      myRow = myRow + 1
    Next myDocumentProperty

    On Error GoTo 0
  End With

  Range(Columns(1), Columns(3)).AutoFit

  myWorkbook.Close SaveChanges:=False
  Set myWorkbook = Nothing
End Sub

ブックに対して、何らかの操作(メソッドを実行したり、プロパティを参照・設定)をする場合、ブックは開いておかなければなりません。これがブックを開いておく理由です。メソッドを実行したり、プロパティを参照・設定したいから、ブックを開くのです。ここでは、開いたブックの組み込みドキュメント情報を参照するためにブックを開きます。
情報はこのマクロを保存しているブックの「Excel」ワークシートに記入します。
順番に番号を取り、名前を参照し、値を参照します。ただし、途中でエラーが発生する名前の箇所もあるので、「On Error Resume Next」ステートメントでエラー発生行の次の行に移動します。
「Range(Columns(1), Columns(3)).AutoFit」は「Columns(“A:C”).AutoFit」とも書けます。なぜこういう書き方をしないかといえば私が慣れていないからです。
VBAを書き始めた頃から、行も列も数字で扱ってきました。理由は、引数に数値変数を直接代入できるからです。引数が文字列では、そういうことができません。
プログラミングの可能性を拡げるためには、行も列も数字で扱うのがいいでしょう。
「Columns(“A:C”).AutoFit」と引数に文字列を使う理由はわかりませんが、あえていうなら、エクセルのデフォルトのセルの表示方法に単に引きずられているだけではないでしょうか。
そういう理由に引きずられて引数に文字列を使うのはよくありません。引数に数値を用いたほうが柔軟なプログラミングができるのはわかりきったことなのですから。
引数に文字列を使うのは、VBAを始めたばかりの初心者の頃だけにしたほうがいいと思います。
引数に文字列を使うのは、恥ずかしいことだという感覚がVBAの学習上、自分がVBAを書けるようになるためには大切だと思います。
最後にブックを保存せずに閉じます。

 

「S_ListBuiltInDocumentProperties_Word」サブプロシージャの解説

Private Sub S_ListBuiltInDocumentProperties_Word _
  (ByVal File As String)

  Dim wdApp As Object
  Set wdApp = CreateObject("Word.Application")
  With wdApp
    .DisplayAlerts = wdAlertsNone
    .Visible = False
  End With

  Dim myDocument As Object
  Set myDocument = wdApp.Documents.Open(Filename:=File)

  Worksheets("Word").Activate
  Cells.ClearContents

  Dim myRow As String: myRow = 1
  Cells(myRow, 2).Value = myDocument.FullName
  myRow = myRow + 1

  On Error Resume Next

  Dim myDocumentProperty As Object
  For Each myDocumentProperty _
    In myDocument.BuiltinDocumentProperties

    Cells(myRow, 1).Value = myRow - 1
    Cells(myRow, 2).Value = myDocumentProperty.Name
    Cells(myRow, 3).Value = myDocumentProperty.Value
    myRow = myRow + 1
  Next myDocumentProperty

  On Error GoTo 0

  Range(Columns(1), Columns(3)).AutoFit

  myDocument.Close SaveChanges:=wdDoNotSaveChanges
  Set myDocument = Nothing
  wdApp.Quit
  Set wdApp = Nothing
End Sub

上述した「S_ListBuiltInDocumentProperties_Excel」も同様ですが、「For Each」文で「myRow」を基準に増分をとって番号を付与していますが、「For」文と違って毎回必ず同じ番号と名前がペアになるわけではありません。
「1番がタイトル」「2番がサブタイトル」「3番が作成者」となっていますが、これは保証されていません。次にこのマクロを実行したときに「1番がサブタイトル」「2番が作成者」「3番が最終更新者」になっても不思議ではありません。これはVBAの仕様です。そういうものだと納得するよりほかありません。
ただし、わたしが何回かマクロを実行したところ、すべて同じ順番でした。

このことについてより詳しい情報がほしいときは次のページが役に立つでしょう。
For Each…Next Statement (Visual Basic) | Microsoft Docs
For Each…Next ステートメント (Visual Basic)
一番重要な部分は次の一文です。

You might not be able to predict which element of the collection is
the first to be returned in element, or which is the next
to be returned after a given element. 

「コレクションのどの要素が最初に返されるか、特定の要素の次にどの要素が返されるかを予測することはできません。」とあります。このマクロについていえば、「どんな順番で名前がセルに表示されるかわかりませんよ」といっていることになります。
ただし、通常使う分には同じ順番で表示されると思ってもよいでしょう。

ここでもう1つ解説するべきは、「Close」メソッドでしょう。「SaveChanges」パラメータに使用できる定数は、「False」ではなく、「wdDoNotSaveChanges」です。エクセルとの違いですね。

 

「S_ListBuiltInDocumentProperties_Powerpoint」サブプロシージャの解説

Private Sub S_ListBuiltInDocumentProperties_Powerpoint _
  (ByVal File As String)

  Dim ppApp As Object
  Set ppApp = CreateObject("Powerpoint.Application")
  ppApp.DisplayAlerts = ppAlertsNone

  Dim myPresentation As Object
  Set myPresentation _
    = ppApp.Presentations.Open(Filename:=File, WithWindow:=msoFalse)

  Worksheets("Powerpoint").Activate
  Cells.ClearContents

  Dim myRow As String: myRow = 1
  Cells(myRow, 2).Value = myPresentation.FullName
  myRow = myRow + 1

  On Error Resume Next

  Dim myDocumentProperty As Object
  For Each myDocumentProperty _
    In myPresentation.BuiltinDocumentProperties

    Cells(myRow, 1).Value = myRow - 1
    Cells(myRow, 2).Value = myDocumentProperty.Name
    Cells(myRow, 3).Value = myDocumentProperty.Value
    myRow = myRow + 1
  Next myDocumentProperty

  On Error GoTo 0

  Range(Columns(1), Columns(3))

  myPresentation.Close
  Set myPresentation = Nothing
  ppApp.Quit
  Set ppApp = Nothing
End Sub

ここでは、やはり「Close」メソッドについて解説しなければなりません。一見、「myPresentation.Close」とシンプルな命令文ですが、ここには書かれていない意味が隠れています。パワポの「Close」メソッドは、作業内容を保存するかどうかを確認するメッセージを表示せずに、開いているファイルを閉じます。ここが大事です。作業内容が保存されていなければ、ファイルの内容はこの命令文で閉じるときに永遠に失われます。失われないようにするには、「Close」メソッドの前に、「Save」メソッドか「SaveAs」メソッドで作業内容を保存してから「Close」メソッドで閉じます。

 

おわりに

今回のマクロで一番注意する点は、ドキュメント情報には2種類のドキュメント情報があるということでしょう。「RemoveDocumentInformation」メソッドで削除できるもの(通常のドキュメント情報)と「BuiltinDocumentProperties」プロパティの「Item」メソッドから削除するもの(組み込みドキュメント情報)との2種類です。
本当は「CustomDocumentProperties」プロパティというものがあるのですが、自分で設定しない限り存在しないものです。

Option Explicit

Sub sample()
  Dim myRow As Long: myRow = 1
  Worksheets("Sheet1").Activate
  On Error Resume Next
  Dim myDocumentProperty As Variant
  For Each myDocumentProperty _
    In ActiveWorkbook.CustomDocumentProperties

      Cells(myRow, 1).Value = myDocumentProperty.Name
      Cells(myRow, 2).Value = myDocumentProperty.Value
      myRow = myrow + 1
  Next
  On Error GoTo 0
End Sub

エクセルのファイルに「Sheet1」というシートが存在するとして、上のマクロを実行して何も起こらなければ、カスタマイズされたドキュメント情報は存在しません。もちろん、通常は存在しないのが当たり前のものです。
したがって、通常は「カスタマイズされたドキュメント情報」は存在しないので、「通常のドキュメント情報」と「組み込みドキュメント情報」が存在するという理解でいいと思います。

もう1つだけ注意する点がありまして、それは「For Each」文ではどんな順番で要素を選ぶかわからない、ということです。これも通常は気にする必要はありませんが、将来他言語にステップアップしようとする方は要注意です。他言語では、バラバラな順番で要素が選ばれるのが当たり前だからです。VBAのように実質的に同じ順番で選ぶということはありません。その違いは頭に入れておいてもいいと思います。

コメントを残す