VBA amacoda

フォルダ内のExcel・Word・Powerpointファイルにパスワードを一括設定するマクロ

Protest Files For Excel/Word/Powerpoint Automatically

2018.07.10 追記

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

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

 

はじめに

任意のフォルダ内にエクセル・ワード・パワポが混在しているとき、会社のルールなどでデータファイルにまとめてパスワードをかけたい場合にファイルを一個一個ひらいてパスワードをかけて保存するのはかなり面倒です。そこで、フォルダ内の全ファイルに、同じパスワードを一気に振る方法を紹介します。

・エクセルで動くマクロです。
・動作は無保証です。
・動作確認は、Windows 10 + Microsoft Excel 2016でおこなっています。
・パワポの「.ppt」「.pptx」「.pptm」以外の拡張子には対応していません。必要ならば、後述する解説を参考に改変してください。
・このマクロを保存するブックにはパスワードはかからないようになっていますので、このブックだけは手動でパスワードを設定してください。
・参照設定は、「Microsoft Scripting Runtime」「Microsoft Word 16.0 Object Library」「Microsoft Powerpoint 16.0 Object Library」に対して参照設定してください（Excel 2016の場合）。

 

パスワードを一括設定するマクロ

Option Explicit

Sub ProtectFilesForExcelWordPowerpoint()
  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 String
  TargetPassword = InputBox _
    ("設定するパスワードを入力してください", "パスワード入力")

  Call S_ProtectFilesForExcel(TargetPath, TargetPassword)
  Call S_ProtectFilesForWord(TargetPath, TargetPassword)
  Call S_ProtectFilesForPowerpoint(TargetPath, TargetPassword)

  MsgBox "パスワード設定完了", vbOKOnly
End Sub

Sub S_ProtectFilesForExcel _
  (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))
    With TargetBook
      If .Name <> myBook Then
        .SaveAs Filename:=(FilePath & buf), _
                Password:=FilePassword
        .Close
      End If
    End With
    buf = Dir()
  Loop

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

Sub S_ProtectFilesForWord _
  (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))
    With TargetDoc
      .Saved = False
      .SaveAs2 Filename:=(FilePath & buf), Password:=FilePassword
      .Close
    End With
    buf = Dir()
  Loop

  wdApp.Quit
  Set wdApp = Nothing
End Sub

Sub S_ProtectFilesForPowerpoint _
  (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), _
           WithWindow:=msoFalse)
        buf.Password = FilePassword
        buf.Save
        buf.Close
        Set buf = Nothing
    End Select
  Next

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

 

メイン処理の解説

構成としては、「メイン処理＋エクセル部分のサブルーチン＋ワード部分のサブルーチン＋パワポ部分のサブルーチン」から成立しています。メイン処理では、パスワードを一括設定するフォルダとそのパスワードを取得し、そのフォルダ名とパスワード文字列をサブルーチンに渡して、それぞれのサブルーチンで自動的にファイルを開き、パスワードを設定し、ファイルを閉じるという作業を繰り返しています。
メイン処理から解説していきます。

Sub ProtectFilesForExcelWordPowerpoint()

マクロの名前です。意味は「エクセル・ワード・パワポのファイルを（パスワードで）保護する」という意味です。自分の好きな名前に変更してかまいません。

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

フォルダのダイアログを表示して、パスワードを設定するフォルダ名を取得します。「.AllowMultiSelect = False」で1つのフォルダのみを選択し、「TargetPath = .SelectedItems(1) & “\”」でフォルダ名と「\」マークを変数「TargetPath」に代入しています。フォルダのダイアログで「キャンセル」ボタンを押すと、処理を中断してマクロを終了します。

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

パスワードを入力するダイアログ（InputBoxメソッド）にパスワードを入力します。InputBoxメソッドで「キャンセル」ボタンを押すと、文字列ではなく、Boolean型の「False」が返ります。ですので、変数「TargetPassword」はバリアント型で宣言しています。そして、「キャンセル」の場合、処理を中断してマクロを終了します。

Call S_ProtectFilesForExcel(TargetPath, TargetPassword)
Call S_ProtectFilesForWord(TargetPath, TargetPassword)
Call S_ProtectFilesForPowerpoint(TargetPath, TargetPassword)

「S_ProtectFilesForExcel」「S_ProtectFilesForWord」「S_ProtectFilesForPowerpoint」という3つのサブルーチンを呼び出しています。それぞれエクセル、ワード、パワポのファイルを呼び出し、パスワードを設定し、保存しています。

MsgBox "パスワード設定完了", vbOKOnly + vbInformation, "パスワード一括設定マクロ"

最後にメッセージボックスを表示して、マクロの終了を確認します。なくてもかまいません。

 

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

Sub S_ProtectFilesForExcel(ByRef FilePath As String, ByRef FilePassword As String)

サブルーチンのタイトルを変えた場合、メイン処理の該当部分も同様に修正する必要があります。パスワードを変えるファイルの存在するフォルダのパスとそのパスワードという2つの引数をメイン処理からもらっています。

With Application
  .ScreenUpdating = False
  .DisplayAlerts = False
End With

「(Application).ScreenUpdating = False」でマクロ実行中の画面更新を停止し、「(Application).DisplayAlerts = False」で確認・警告メッセージを非表示にしています。

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))
  With TargetBook
    If .Name <> myBook Then
      .SaveAs Filename:=(FilePath & buf), _
              Password:=FilePassword
      .Close
    End If
  End With
  buf = Dir()
Loop

「buf = Dir(FilePath & “*.xls*”)」で、エクセルファイルの存在を確認し、最初のファイル名を返しています。テンプレートやアドインを含めて検索する場合は「buf = Dir(FilePath & “*.xl*”)」としてください。「myBook = ThisWorkbook.Name」でこのマクロの記録されているブック名を取得しています。「Do While buf <> “” ～ Loop」で、エクセルファイルが存在する限り、（エクセルファイルにパスワードを設定し、保存するという）作業を繰り返します。「Set TargetBook = Workbooks.Open(Filename:=(FilePath & buf))」で開いたブックのブック名を変数「TargetBook」に代入しています。ブック名がこのマクロを保存しているブックでない限り（If (TargetBook).Name <> myBook Then ～ End If）、「(TargetBook).SaveAs Filename:=(FilePath & buf), Password:=FilePassword」でブックにパスワードを付けて保存しています。「buf = Dir()」で残りのファイル名を取得しています。

 

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

Sub S_ProtectFilesForWord(ByRef FilePath As String, ByRef FilePassword As String)

サブルーチンのタイトルを変えた場合、メイン処理の該当部分も同様に修正する必要があります。パスワードを変えるファイルの存在するフォルダのパスとそのパスワードという2つの引数をメイン処理からもらっています。この部分はエクセルと同じ構造になっています。

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

Object型でオブジェクト変数「WdApp」を宣言し、CreateObject関数でワードへの参照を作成しています。「(Application).DisplayAlerts = False」で確認・警告メッセージを非表示にして、「(Application).Visible = False」でワードを非表示にしています。非表示にしたのは、エクセルでマクロ実行中の画面更新を停止したのと同じ理由です。エクセルマクロ上で、ワードの「(Application).ScreenUpdating = False」はエクセルのそれと混同してしまうので、同じ効果を期待できるものにしています。

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

「buf = Dir(FilePath & “*.doc*”)」でワードファイルの存在を確認し、最初のファイル名を返しています。テンプレートを含めて検索する場合は「buf = Dir(FilePath & “*.do*”)」としてください。「Do While buf <> “” ～ Loop」で、ワードファイルが存在する限り、（ワードファイルにパスワードを設定し、保存するという）作業を繰り返しています。「Set TargetDoc = Documents.Open(Filename:=(FilePath & buf))」で開いた文書の文書名を変数「TargetDoc」に代入しています。 「(TargetDoc).Saved = False」にはワードの特徴が出ています。ワードマクロでは、何か書き込みをしないと保存できないという仕様があるので、その書き込みフラグを立てるために、「Saved」プロパティに「False」を代入しています。「Saved」プロパティは文書が最後に保存されてから何か変更が行われているかどうかを確認するプロパティで、「True」なら何も変更されていない（全部保存されている）、「False」なら変更されている部分がある（一部保存されていない）という意味になります。ここでは「名前を付けて保存」を実行するために、「Saved」プロパティに「False」を設定して、文書に一部保存されていない部分があるというフラグを立てています。ワードマクロの仕様に対応するための苦肉の策です。 「(TargetDoc).SaveAs2 Filename:=(FilePath & buf), Password:=FilePassword」で文書にパスワードを付けて保存しています。ワードマクロでは2010には「SaveAs」メソッドがありますが、パスワード付きで保存することはできません。2010以降では「SaveAs2」メソッドでパスワード付きで保存することができます。（2013は未確認）。これはエクセルマクロ・パワポマクロとも違う「名前を付けて保存」の仕様です。 「(TargetDoc).Close」で文書を閉じて、「buf = Dir()」で残りのファイル名を取得しています。

wdApp.Quit
Set wdApp = Nothing

「wdApp.Quit」でワードを終了した後で、「Set wdApp = Nothhing」でワードへの参照を破棄しています。本来は「Set wdApp = Nothhing」は不要です。ワードを終了した時点で自動的にワードへの参照は破棄されるからです。ここでは、何らかの理由でワードへの参照が破棄されなかったときのために、念のため明示的にワードへの参照を破棄しています。

 

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

Sub S_ProtectFilesForPowerpoint(ByRef FilePath As String, ByRef FilePassword As String)

サブルーチンのタイトルを変えた場合、メイン処理の該当部分も同様に修正する必要があります。パスワードを変えるファイルの存在するフォルダのパスとそのパスワードという2つの引数をメイン処理からもらっています。この部分はエクセル・ワードと同じ構造になっています。

Dim fso As Object
Dim TargetFolder As Folder
Set fso = CreateObject("Scripting.FileSystemObject")
Set TargetFolder = fso.GetFolder(FilePath)

この部分はエクセル・ワード部分とは根本的に異なっています。最初は、エクセル・ワードと同じように「Dir」関数を使ってやろうとしていました。実際、前段階としてパワポ単体のマクロでは「Dir」関数できちんと動作確認がとれました。ところが、エクセル上に移植したところ、「Dim TargetPrs As Presentation ～ Set TargetPrs = Presentations.Open(Filename:=(FilePath & buf))」の部分で実行エラーが出て、開いたプレゼンテーションを変数「TargetPrs」に格納できませんでした。やむをえず、方針を変更してパワポだけはFileSystemObjectを利用することにしました。 「Dim ～」で変数「fso」「TargetFolder」を宣言し、「Set fso = CreateObject(“Scripting.FileSystemObject”)」でFileSystemObjectオブジェクトのインスタンスを変数「fso」に格納し、「Set TargetFolder = fso.GetFolder(FilePath)」でパスワードを付けて保存するファイルが保存されているフォルダのオブジェクトを変数「TargetFolder」に格納しています。

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

Object型でオブジェクト変数「ppApp」を宣言し、CreateObject関数でパワポへの参照を作成しています。「ppApp.DisplayAlerts = ppAlertsNone」で確認・警告メッセージを非表示にしています。パワポの場合、「DisplayAlerts」に設定できる値は「True / False」ではなく、「ppAlertsAll / ppAlertsNone」です。「ppAlertsNone」は既定値ですが、明示的に示しています。ここはエクセル・ワードとは違います。エクセルの場合は更新停止（ScreenUpdating = False）、ワードの場合は非表示（Visible = False）のステートメントを作成していましたが、パワポではそのようなステートメントは作成できないので、別のステートメントで同様の効果を生んでいます。

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), _
         WithWindow:=msoFalse)
      buf.Password = FilePassword
      buf.Save
      buf.Close
      Set buf = Nothing
  End Select
Next

エクセル・ワードのように「Dir」関数を「Do ～ Loop」で回す代わりに、パワポでは「For each ～ Next」で回しています。変数「TargetFile」にはフォルダ内のそれぞれのファイルを格納することとし、変数「TargetExtension」にはその拡張子を格納し、その2つでパワポのファイルかどうかを判断しています。「Case “ppt”, “pptx”, “pptm”」がそれですが、パワポの拡張子はそれだけではありません。テンプレート系の拡張子は「pot、potx、potm」、スライドショー系の拡張子は「pps、ppsx、ppsm」、アドイン系の拡張子は「ppa、ppam」ですので、「Case “ppt”, “pptx”, “pptm”」の後にそれぞれ追加してください。すると「For each ～ Next」を回す間に検索するようになります。 「Select case ～ End Select」でパワポのファイルを特定し、変数「buf」に開いたパワポファイルを代入しています。その時に「WithWindow:=msoFalse」としウィンドウを非表示にしています。パワポマクロでウィンドウを非表示にする場合はこのようにします。「Application.Visible」プロパティは調べたところ「オブジェクトの表示／非表示」に関するプロパティではなく、「オブジェクトの書式設定の表示／非表示」に関するプロパティだったので使わず、ファイルを開くときに引数の設定でウィンドウを非表示にしています。 パスワードの設定方法もエクセル・ワードとは違います。まず「buf.Password」でパスワードを設定し、それから「buf.Save」で上書き保存し、「buf.Close」でファイルを閉じています。「Set buf = Nothing」でファイルへの参照を破棄しています。

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

パワポ・アプリケーションを終了し、パワポアプリケーションへの参照を破棄し、フォルダへの参照を破棄し、FileSystemObjectのインスタンスへの参照を破棄しています。厳密にはこの「～Nothing」はなくてもかまいません。

 

おわりに

エクセルの単体のマクロを作っているときは順調でした。しかし、ワードとパワポの単体のマクロを作る時点から調べものにかなり時間を費やしました。具体的にはエクセルでいう画面更新の停止、ワード・パワポでは画面の非表示の作法がそれぞれ微妙に違うのがやっかいでした。さらにやっかいだったのが、パスワードを付けて保存する作法の違いでした。ワードではトリッキーな策を講じないとマクロが動作しませんし、パワポでは先にパスワードを付けて上書き保存をするという、エクセルとはまるで違うやり方なのが大変困りました。 やっかいはさらに続き、パワポでは動いていた「Dir」関数が理由もわからず動かなかったので、急きょ「FileSystemObject」に変更しました。 その結果、動作確認がとれたので公開しました。サブフォルダのファイルも操作するマクロも考えましたが、時間がかかるので、現在、鋭意開発中です。 このマクロを使ってくださると、たいへんうれしいです。

コメントを残す

RECOMMENDこちらの記事も人気です。