フォルダ内のExcel/Accessファイルの個人情報を一括削除するVBA

普段使うぶんには困らないのですが、外に出すファイルでは消したいプロパティ情報。該当のものだけ1つのフォルダにまとめておいて、その中にあるファイルのプロパティを全部消してくれる、みたいなのがほしいな～と思って書いてみました。

ファイルの「個人情報」をまとめて消したい

Excelの場合は、ファイルを右クリック→プロパティの「詳細」タブで見えるココ。

Accessは、ファイルを開いて「ファイル」→「情報」→「データベースのプロパティの表示および編集」の「ファイルの概要」タブで見えるココ。

このあたり、外部に出すファイルならば消しておきたいですよね。手動なら「プロパティや個人情報を削除」をすればよいのですが。

ファイルの数が多かったり、サブフォルダで階層になっちゃってたりしたら1つ1つやるのは嫌だな～～。

というわけで、該当ファイルをまとめておいてパスを指定すればその中身をまるっとやってくれるのを目指しました。

メインプロシージャ

以下が実行するプロシージャ。ExcelVBAです。

'ファイル名を格納する配列と要素数の宣言
Private fileAry() As String, n As Long

'------------- ↑宣言セクションへ -------------

Sub deleteProperty()
  '## メインプロシージャ
  
  Dim tgtPath As String
  tgtPath = "C:\hoge" '任意のパス
  
  'ファイル一覧作成
  Erase fileAry '初期化
  n = 0
  Call makeFileAry(tgtPath) 'ファイル名を配列に入れる
  
  Dim defaultName As String
  defaultName = Application.UserName 'ユーザ名を一時的に記憶
  Application.UserName = " " '仮ユーザ名
  
  '配列内をループ
  Dim i As Long
  For i = 0 To UBound(fileAry)
    Select Case Right(fileAry(i), 5)
      Case "accdb" 'Accessファイルの場合
        Call delAccessProperty(fileAry(i))
      Case ".xlsx", ".xlsm" 'Excelファイルの場合
        Call delExcelProperty(fileAry(i))
      Case Else
        Debug.Print fileAry(i) '未処理のファイルはイミディエイトウィンドウに出力
    End Select
  Next i
  
  Application.UserName = defaultName 'ユーザ名を復元する
  
  MsgBox "終了しました", vbInformation, "確認"
End Sub

ハイライト部分で計3つのプロシージャを呼び出しています。まずは指定のパスを引数に、その中（サブフォルダ含め）のファイル名をすべて配列に格納するプロシージャ（15行目）。

取得した配列の中身をループで確認して、拡張子によってファイル形式を判別しています。該当する形式だったら、配列に入っていたファイル名（フルパス）を引数にしてAccessなら26行目、Excelなら28行目のプロシージャを呼び出します。

呼び出しているプロシージャの詳細は以下です。

指定パス内のすべてのファイル名を配列へ格納するプロシージャ

上記コードの15行目で呼び出しているプロシージャです。先述の宣言セクションへ書いたモジュールレベル変数を使っていますので、その記述がないとエラーになってしまうのでご注意ください。

Sub makeFileAry(tgtPath As String)
  '## サブフォルダ含めて指定フォルダ内のすべてのファイル名を配列へ
  
  'サブフォルダ内のファイル名取得へ
  Dim fol As Object
  With CreateObject("Scripting.FileSystemObject")
    For Each fol In .GetFolder(tgtPath).SubFolders
      Call makeFileAry(fol.Path)
    Next fol
  End With
  
  'ファイル名取得
  Dim buf As String: buf = Dir(tgtPath & "\*.*")
  Do While buf <> ""
    ReDim Preserve fileAry(n) As String '配列の要素数を変更
    fileAry(n) = tgtPath & "\" & buf 'ファイル名を配列へ
    n = n + 1 'ファイル数カウントアップ
    buf = Dir()
  Loop
End Sub

Excelファイルのプロパティを消すプロシージャ

引数のファイルがExcelだった場合の処理です。

Sub delExcelProperty(ByVal fileName As String)
  '## Excelファイルのプロパティを削除する
  
  On Error GoTo ErrHandler
  
  Dim wb As Workbook
  Set wb = Workbooks.Open(fileName)
  
  '文字列型のドキュメントプロパティのみ消去
  Dim dp As DocumentProperty
  For Each dp In wb.BuiltinDocumentProperties
    If dp.Type = msoPropertyTypeString Then
      dp.Value = Empty
    End If
  Next
  
  'その他の型のドキュメントプロパティを消去
  With wb.BuiltinDocumentProperties
    .Item("Revision number").Value = Empty '改訂番号
    .Item("Document version").Value = Empty 'バージョン番号
    .Item("Application name").Value = Empty 'アプリケーション名
     
    .Item("Creation Date").Value = Now '作成日時
    .Item("Last Save Time").Value = Now '更新日時
    Dim baff As Variant: baff = .Item("Last Print Date").Value '印刷日時を取得 *存在しなければエラーになる
continue:
    If IsDate(baff) Then
      .Item("Last Print Date").Value = Now '日付形式の印刷日時が存在した場合のみ上書き
    End If
  End With
  
  wb.Close saveChanges:=True '保存して閉じる
  
  Set wb = Nothing
  Exit Sub
  
ErrHandler:
  If Err.Number = -2147467259 Then
    '印刷日時が取得できなかった時のエラー
    GoTo continue
  Else
    '予期していないエラー時
    Err.Raise Number:=Err.Number, Description:=Err.Description
  End If
End Sub

引数として持ってきたファイル名（フルパス）を使って該当ファイルを開いて上書き保存しています。上書き保存が気になる方はコピーしたファイルを使ったり、出力先やファイル名を変えるなど工夫してみてくださいね。

ハマったのが「印刷日時」でして、ファイルによって有無が違うんですよね。上に倣って問答無用で日付を書き込んでしまえばもちろんそれでもOKだったのですが、もともと無かったなら無いままにしておきたいなあと思ってしまって。この日付型プロパティ、一度書き込むとEmptyやNullにはできないみたいで、存在していない場合はアクセスするとエラーになります。

それならばと、いったん取得するコードを通らせて（25行目）、もし存在しなければエラーで37行目に飛んでくるので、そこで指定のエラー番号だったら「印刷日時が存在しない」とみなしてcontinue行（26行目）へ戻る、という小細工をしました。

特に気にならない方はこんなエラートラップ仕込まずに、元々の印刷日時の有無に関わらず日付を書いちゃったほうが楽です。

Accessファイルのプロパティを消すプロシージャ

引数のファイルがAccesssだった場合の処理。ExcelVBAで書いているのでAccessアプリ用オブジェクトの用意が必要です。

Sub delAccessProperty(ByVal fileName As String)
  '## Accessファイルのプロパティを削除する
  
  Dim Acc As Object
  Set Acc = CreateObject("Access.application") 'Accessアプリ
  Acc.OpenCurrentDatabase fileName '指定ファイルを開く
  
  On Error Resume Next 'エラーが起きても進む
  
  With Acc.CurrentDb
    With .Containers("Databases").Documents("SummaryInfo")
      .Properties("Title").Value = " " 'タイトル *以下、存在しなければエラーになる
      .Properties("Subject").Value = " " 'サブタイトル
      .Properties("Author").Value = " " '作成者
      .Properties("Manager").Value = " " '管理者
      .Properties("Company").Value = " " '会社名
      .Properties("Category").Value = " " '分類
      .Properties("Keywords").Value = " " 'キーワード
      .Properties("Comments").Value = " " 'コメント
      .Properties("Hyperlink base").Value = " " 'ハイパーリンクの基点
    End With
  End With
  
  On Error GoTo 0 'エラー処理無効
  
  Acc.Quit '終了
  
  Set Acc = Nothing
End Sub

引数として持ってきたファイル名（フルパス）を使って該当ファイルを開いて上書き保存しています。こちらも上書き保存が気になる方は工夫してみてくださいね。日付系も取得はできましたがReadOnlyのようで、VBAでどうにかなるのはこのあたりかな～と。

上で書いたプロパティはEmptyやNullは書き込めず、存在していない場合はアクセスするとエラーになります。したがって、On Error Resume Nextでエラーを無視しながら進み、なにかが書かれているプロパティにのみ「” “（半角スペース）」を上書きする形です。

ただこれだと10～22行目の間は他の予期せぬエラーは拾えないですね（この間でそんなにエラーも起こりにくいかなという気はしていますが）。もうちょっと良いやり方が思いついたらいいな。

以上です！