Unprotest Files For Excel/Word/Powerpoint Automatically

2018.07.10 追記

こちらのマクロは単独フォルダのファイルに対するパスワードを解除するマクロです。

複数フォルダのファイルに対するパスワードを解除するマクロは別ページにあります。こちらのページをご覧ください。

はじめに

このマクロは「フォルダ内のExcel・Word・Powerpointファイルにパスワードを一括設定するマクロ」と対をなすマクロです。まずはそちらをお読みください。こちらのマクロは、一括設定とは違う一括解除に特有な部分を解説します。

・エクセルで動くマクロです。
・動作は無保証です。
・動作確認は、Windows 10 + Microsoft Excel 2016でおこなっています。
・参照設定は、「Microsoft Scripting Runtime」「Microsoft Word 16.0 Object Library」「Microsoft Powerpoint 16.0 Object Library」に対して参照設定してください（Excel 2016の場合）。

パスワードを一括解除するマクロ

Option Explicit

Sub UnprotectFilesForExcelWordPowerpoint()
  Dim TargetPath As String
  With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = True Then
      TargetPath = .SelectedItems(1) & "\"
    Else
      Exit Sub
    End If
  End With

  Dim TargetPassword As Variant
  TargetPassword = InputBox _
    ("解除するパスワードを入力してください", "パスワード入力")
  If TargetPassword = False Then Exit Sub

  Call S_UnprotectFilesForExcel(TargetPath, TargetPassword)
  Call S_UnprotectFilesForWord(TargetPath, TargetPassword)
  Call S_UnprotectFilesForPowerpoint(TargetPath, TargetPassword)

  MsgBox "パスワード解除完了", vbOKOnly + vbInformation, "パスワード一括解除マクロ"
End Sub

Sub S_UnprotectFilesForExcel _
  (ByRef FilePath As String, ByRef FilePassword As String)
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With

  Dim buf As String
  Dim myBook As String
  Dim TargetBook As Workbook
  buf = Dir(FilePath & "*.xls*")
  myBook = ThisWorkbook.Name
  Do While buf <> ""
    Set TargetBook = Workbooks.Open _
        (Filename:=(FilePath & buf), Password:=FilePassword)
    With TargetBook
      If .Name <> myBook Then
        .SaveAs Filename:=(FilePath & buf), Password:=""
        .Close
      End If
    End With
    buf = Dir()
  Loop

  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

Sub S_UnprotectFilesForWord _
  (ByRef FilePath As String, ByRef FilePassword As String)
  Dim wdApp As Object
  Set wdApp = CreateObject("Word.Application")
  With wdApp
    .DisplayAlerts = False
    .Visible = False
  End With

  Dim buf As String
  Dim TargetDoc As Document
  buf = Dir(FilePath & "*.doc*")
  Do While buf <> ""
    Set TargetDoc = Documents.Open _
        (Filename:=(FilePath & buf), PasswordDocument:=FilePassword)
    With TargetDoc
      .Saved = False
      .SaveAs2 Filename:=(FilePath & buf), Password:=""
      .Close
    End With
    buf = Dir()
  Loop

  wdApp.Quit
  Set wdApp = Nothing
End Sub

Sub S_UnprotectFilesForPowerpoint _
  (ByRef FilePath As String, ByRef FilePassword As String)
  Dim fso As Object
  Dim TargetFolder As Folder
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set TargetFolder = fso.GetFolder(FilePath)

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

  Dim TargetFile As Object
  Dim TargetExtension As String
  Dim buf As Object
  For Each TargetFile In TargetFolder.Files
    TargetExtension = LCase(fso.GetExtensionName(TargetFile.Name))
    Select Case TargetExtension
      Case "ppt", "pptx", "pptm"
        Set buf = ppApp.Presentations.Open _
          (Filename:=(TargetFolder & "\" & TargetFile.Name & "::" & FilePassword), _
           WithWindow:=msoFalse)
        buf.Password = ""
        buf.Save
        buf.Close
        Set buf = Nothing
    End Select
  Next

  ppApp.Quit
  Set ppApp = Nothing
  Set TargetFolder = Nothing
  Set fso = Nothing
End Sub

メイン処理の解説

構成としては、「メイン処理＋エクセル部分のサブルーチン＋ワード部分のサブルーチン＋パワポ部分のサブルーチン」から成立しています。メイン処理では、パスワードを一括解除するフォルダとそのパスワードを取得し、そのフォルダ名とパスワード文字列をサブルーチンに渡して、それぞれのサブルーチンで自動的にパスワードを入力してファイルを開き、パスワードを解除し、ファイルを保存して閉じるという作業を繰り返しています。メイン部分で一括設定と違う部分はメッセージで「設定」という文字が「解除」に変わってる点だけで、処理自体は一括設定の場合とまったく同じです。

Call S_UnprotectFilesForExcel(TargetPath, TargetPassword)
Call S_UnprotectFilesForWord(TargetPath, TargetPassword)
Call S_UnprotectFilesForPowerpoint(TargetPath, TargetPassword)

「S_UnprotectFilesForExcel」「S_UnprotectFilesForWord」「S_UnprotectFilesForPowerpoint」という3つのサブルーチンを呼び出しています。それぞれエクセル、ワード、パワポのファイルを呼び出し、パスワードを解除して開き、保存しています。

エクセル部分のサブルーチンの解説

Dim buf As String
Dim myBook As String
Dim TargetBook As Workbook
buf = Dir(FilePath & "*.xls*")
myBook = ThisWorkbook.Name
Do While buf <> ""
  Set TargetBook = Workbooks.Open _
      (Filename:=(FilePath & buf), Password:=FilePassword)
  With TargetBook
    If .Name <> myBook Then
      .SaveAs Filename:=(FilePath & buf), Password:=""
      .Close
    End If
  End With
  buf = Dir()
Loop

「Set TargetBook = Workbooks.Open(Filename:=(FilePath & buf), Password:=FilePassword)」パスワード付きでファイルを開き、保存するときは「Password:=””」とパスワードに空の文字列を渡して保存しています。

ワード部分のサブルーチンの解説

Dim buf As String
Dim TargetDoc As Document
buf = Dir(FilePath & "*.doc*")
Do While buf <> ""
  Set TargetDoc = Documents.Open _
      (Filename:=(FilePath & buf), PasswordDocument:=FilePassword)
  With TargetDoc
    .Saved = False
    .SaveAs2 Filename:=(FilePath & buf), Password:=""
    .Close
  End With
  buf = Dir()
Loop

ワードの場合は、ファイルを開くときの名前付き引数が「Password」ではなく、「PasswordDocument」となっている点に注意が必要です。また、ファイルを名前を付けて保存するメソッドでパスワードを渡す名前付き引数は「Password:=””」です。

パワポ部分のサブルーチンの解説

Dim TargetFile As Object
Dim TargetExtension As String
Dim buf As Object
For Each TargetFile In TargetFolder.Files
  TargetExtension = LCase(fso.GetExtensionName(TargetFile.Name))
  Select Case TargetExtension
    Case "ppt", "pptx", "pptm"
      Set buf = ppApp.Presentations.Open _
        (Filename:=(TargetFolder & "\" & TargetFile.Name & "::" & FilePassword), _
         WithWindow:=msoFalse)
      buf.Password = ""
      buf.Save
      buf.Close
      Set buf = Nothing
  End Select
Next

パワポの部分はファイルを開く部分を調べるのに非常に苦労しました。パワポの「Open」メソッドには「Password:=」に相当する名前付き引数が存在しません。じゃあ、どうやってパスワード付きのファイルをマクロで開くのか? 大変苦労して調べた結果、ファイル名に続けて「::」と「パスワードの文字列」を設定すればマクロで開くことができると判明しました。解除するには「buf.Password = “”」としてから保存して閉じます。

おわりに

このマクロではパスワード付きのパワポファイルをマクロで開くのに非常に苦労しました。パスワードを一括設定するマクロにくらべれて需要は低いかもしれませんが、やはり対になるマクロはあったほうがいいと思い、公開に至りました。このマクロを使ってくださると大変うれしいです。