【SendTo】パスワードを一括設定/解除する(Excel/Word/PowerPoint)

これは何？

複数のExcelファイルにパスワード(読み取り/書き込み)を設定/解除するスクリプト。対象のファイルはすべて上書き保存するので注意。
おまけで、ブック毎にパスワード設定/解除が成功したかを一覧化する簡素レポート機能付き。
SendToフォルダに置いて使う。(%APPDATA%\Microsoft\Windows\SendTo)

VBA表示用パスワードはサポート外

ExcelはVBAの表示にパスワード制限を掛けることができるが、簡単に解除できてしまう。(主な解除方法は後述の2つ)
設定しても気休めにしかならないのでサポートしない。コードを秘匿化したいならアドインで実装すべし。

解除方法1. パスワードを無理やり書き換える

Excelファイルをバイナリエディタで直接書き換える方法。
https://www.google.com/search?q=Excel+VBA+パスワード+バイナリエディタ

解除方法2. パスワード入力をバイパスする

Excelが呼び出すWIN32APIのコードを(無理矢理)書き換えて、パスワードの入力画面をバイパスする方法。
メモリのアクセス権限の変更＋実行コードの書き換えという挑戦的なことをしているため、ウイルス対策ソフトなどが反応するかもしれない。
なので会社PCなどではオススメできない。

参考：https://tsurutoro.com/problem-solving/
(コードリーディング結果を記事にする予定)

コード

パスワード一括解除とパスワード一括設定のコードを共通化したため、コンパイルスイッチで切替可能。

コンパイルスイッチ

OPE_MODE

動作モードを決定する。

設定値	動作
OPE_MODE__UNLOCK	パスワードを解除する。
OPE_MODE__LOCK	パスワードを設定する。

FLG_REUSE_PROCESS

プロセスを使いまわすかを決定する。

基本は1つのプロセスで複数のファイルを処理する。(プロセスの起動/終了は処理負荷が大きく、ファイル毎にプロセスを起動していては時間がかかるため)
ただしWindows10(Excel2016も)は動作が不安定で急にプロセス停止になることが稀に良くあるため、環境によってはファイル毎に起動した方が良い場合がある。

設定値	動作
True	1つのプロセスで複数のファイルを処理する。
False	ファイル毎にプロセスを分けて処理する。

パスワード一括解除

エントリポイント～メイン関数の呼び出し

内容：定数定義、グローバルオブジェクトの作成。

パスワードを一括解除する.vbs

Option Explicit
Const   xlWBATWorksheet                 = -4167 

' コンパイルスイッチ(動作モード)
Const OPE_MODE__UNLOCK                  = 1
Const OPE_MODE__LOCK                    = 2
Const OPE_MODE                          = 1     ' OPE_MODE__UNLOCK

' コンパイルスイッチ(1つのプロセスで複数のファイルを処理する)
Const FLG_REUSE_PROCESS                 = True

' 定数(文法上Constを付けれない)
Dim LABEL_PSWD_CAPTION
Dim LABEL_READ_PSWD_PROMPT
Dim LABEL_WRIT_PSWD_PROMPT
If OPE_MODE = OPE_MODE__UNLOCK Then
    LABEL_PSWD_CAPTION                  = "パスワード一括解除"
    LABEL_READ_PSWD_PROMPT              = "現在の読み取りパスワードを入力"
    LABEL_WRIT_PSWD_PROMPT              = "現在の書き込みパスワードを入力"
ElseIf OPE_MODE = OPE_MODE__LOCK Then
    LABEL_PSWD_CAPTION                  = "パスワード一括設定"
    LABEL_READ_PSWD_PROMPT              = "新しい読み取りパスワードを入力 (省略時はパスワード設定なし)"
    LABEL_WRIT_PSWD_PROMPT              = "新しい書き込みパスワードを入力 (省略時はパスワード設定なし)"
End If

' グローバルオブジェクト
Dim FSO:    Set FSO = CreateObject("Scripting.FileSystemObject")
Dim WSH:    Set WSH = CreateObject("WScript.Shell")

' グローバル変数
' 1つのプロセスで複数のファイルを処理する場合のオブジェクト
Dim g_objExcelAppShare:                 Set g_objExcelAppShare = Nothing
Dim g_objWordAppShare:                  Set g_objWordAppShare = Nothing
Dim g_objPowerpointAppShare:            Set g_objPowerpointAppShare = Nothing

Main

WScript.Quit

メイン関数

内容：ファイルの上書き確認、エクセル起動(レポート用)、パスワード入力、コマンドライン引数の処理、パスワード設定/解除用プロセスの終了。

パスワード入力は読み取りパスワードの入力ダイアログを表示する。
書き込みパスワードは以下の通り。(ただしコメントアウトを外せば入力ダイアログで入力できる)
■「OPE_MODE=OPE_MODE_UNLOCK」のとき
　読み取りパスワードと同じものを使う。
■「OPE_MODE=OPE_MODE_LOCK」のとき
　書き込みパスワードは設定しない。

パスワードを一括解除する.vbs

'***********************************************************
' メイン関数
'***********************************************************
Sub Main()
    Dim vbReturn
    Dim flgReport
    Dim objExcelApp
    Dim wsReport
    Dim strArgument
    Dim strReadPassword
    Dim strWritePassword

    ' 上書き保存の確認
    vbReturn = MsgBox("このスクリプトは処理対象のファイルを上書き保存します。実行しますか？", vbYesNo + vbDefaultButton2)
    If vbReturn = vbYes Then
        ' 処理を続行
    Else
        Exit Sub
    End If

    ' レポート出力の確認
    vbReturn = vbYes
    ' vbReturn = MsgBox("実施結果レポートを作成しますか？", vbYesNoCancel)
    If vbReturn = vbYes Then
        flgReport = True
    ElseIf vbReturn = vbNo Then
        flgReport = False
    Else
        Exit Sub
    End If

    ' Excelを起動
    Set objExcelApp = CreateObject("Excel.Application")

    ' Excelを可視化
    objExcelApp.Visible = True

    ' 読み取りパスワードを入力
    strReadPassword = objExcelApp.InputBox(LABEL_READ_PSWD_PROMPT, LABEL_PSWD_CAPTION, "password")

    ' 書き込みパスワードを入力
If OPE_MODE = OPE_MODE__UNLOCK Then
    strWritePassword = strReadPassword      ' 解除時は読み取りパスワードと同じものを使う
ElseIf OPE_MODE = OPE_MODE__LOCK Then
    strWritePassword = ""                   ' 設定時はパスワード保護なし
End If
    ' (ユーザ入力が必要ならコメントアウトを外す)
    ' strWritePassword = objExcelApp.InputBox(LABEL_WRIT_PSWD_PROMPT, LABEL_PSWD_CAPTION, "password")

    ' レポート出力用のブックを作成
    If flgReport = True Then
        Set wsReport = objExcelApp.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    Else
        Set wsReport = Nothing
    End If

    ' コマンドラインのファイルを順に処理する
    For Each strArgument In WScript.Arguments.Unnamed
        ' エラーが発生したファイルは無視して先に進める
        On Error Resume Next

        ' パスワードを設定/解除して上書き保存する
        ' レポートを出力
        ' 注意：Errオブジェクトが更新されないように「UpdatePasswordLock」の直後でErrを参照すること。
        '       (途中に一切のステートメントを挟まないこと)
        Call UpdatePasswordLock(strArgument, strReadPassword, strWritePassword)
        Call WriteReport(wsReport, strArgument, Err)

        On Error Goto 0
    Next

    ' Excelを終了
    If objExcelApp.Workbooks.Count = 0 Then  Call objExcelApp.Quit()

If FLG_REUSE_PROCESS = True Then
    ' 1つのプロセスで複数のファイルを処理する場合

    ' 共用プロセスを終了する(Excel)
    ' Assert g_objExcelAppShare <> objExcelApp
    If Not (g_objExcelAppShare Is Nothing) Then
        If g_objExcelAppShare.Workbooks.Count = 0 Then  Call g_objExcelAppShare.Quit()
    End If

    ' 共用プロセスを終了する(Word)
    If Not (g_objWordAppShare Is Nothing) Then
        If g_objWordAppShare.Documents.Count = 0 Then  Call g_objWordAppShare.Quit()
    End If

    ' 共用プロセスを終了する(Powerpoint)
    If Not (g_objPowerpointAppShare Is Nothing) Then
        If g_objPowerpointAppShare.Presentations.Count = 0 Then  Call g_objPowerpointAppShare.Quit()
    End If
End If

    ' 参照を解放する
    ' メモ：ＭＳを信じれば(足を)すくわれる
    Set wsReport = Nothing
    Set objExcelApp = Nothing

End Sub

拡張子に応じて処理を振り分ける

内容：タイトル通り。
ショートカットは非サポートとしているが、コメントアウトを外せば使えるようになる。

パスワードを一括解除する.vbs

'***********************************************************
' パスワードを設定/解除して上書き保存する
'***********************************************************
Sub UpdatePasswordLock(strFile, strReadPassword, strWritePassword)
    Dim wshShortcut

    Select Case FSO.GetExtensionName(strFile)
    '-----------------------------------------------------------
    ' Excelで開く拡張子
    '-----------------------------------------------------------
    Case "xls"
        ' パスワードを設定/解除して上書き保存する (Excel)
        Call UpdatePasswordLockExcel(strFile, strReadPassword, strWritePassword)
    Case "xlsx"
        ' パスワードを設定/解除して上書き保存する (Excel)
        Call UpdatePasswordLockExcel(strFile, strReadPassword, strWritePassword)
    Case "xlsm"
        ' パスワードを設定/解除して上書き保存する (Excel)
        Call UpdatePasswordLockExcel(strFile, strReadPassword, strWritePassword)

    '-----------------------------------------------------------
    ' Wordで開く拡張子
    '-----------------------------------------------------------
    Case "doc"
        ' パスワードを設定/解除して上書き保存する (Word)
        Call UpdatePasswordLockWord(strFile, strReadPassword, strWritePassword)
    Case "docx"
        ' パスワードを設定/解除して上書き保存する (Word)
        Call UpdatePasswordLockWord(strFile, strReadPassword, strWritePassword)
    Case "docm"
        ' パスワードを設定/解除して上書き保存する (Word)
        Call UpdatePasswordLockWord(strFile, strReadPassword, strWritePassword)

    '-----------------------------------------------------------
    ' PowerPointで開く拡張子
    '-----------------------------------------------------------
    Case "ppt"
        Call UpdatePasswordLockPowerpoint(strFile, strReadPassword, strWritePassword)
    Case "pptx"
        Call UpdatePasswordLockPowerpoint(strFile, strReadPassword, strWritePassword)
    Case "pptm"
        Call UpdatePasswordLockPowerpoint(strFile, strReadPassword, strWritePassword)

    '-----------------------------------------------------------
    ' ショートカットはショートカット先を開く
    '-----------------------------------------------------------
    ' ⇒  開かない。
    '     ショートカットはリンク切れになると(原因：リンク先ファイルのリネームなど)
    '     リネーム後のファイルを推測してリンク先を勝手に書き換えることがあるため、
    '     ファイルを上書きする本スクリプトでは非サポートとする。
    '     ↓
    '     有効にするには以下のコメントを外す
    ' Case "lnk"
    '   Set wshShortcut = WSH.CreateShortcut(strFile)
    '   ' ショートカット先を再帰処理
    '   Call UpdatePasswordLock(wshShortcut.TargetPath, strReadPassword, strWritePassword)

    '-----------------------------------------------------------
    ' その他
    '-----------------------------------------------------------
    Case Else
        ' 非サポートの拡張子である旨をエラー通知する (No-Return)
        Call RaiseUnsupportedExtensionError(strFile, "UpdatePasswordLock")
        Exit Sub        ' 到達しないが、念のため。

    End Select

End Sub

Excelファイルのパスワードを設定/解除する

内容：Excelファイルを開いてパスワードを設定/解除し、上書き保存して閉じる。

パスワードを一括解除する.vbs

'***********************************************************
' パスワードを設定/解除して上書き保存する (Excel)
'***********************************************************
Sub UpdatePasswordLockExcel(strFile, strReadPassword, strWritePassword)
    Dim objExcelApp
    Dim wbTargetFile

    ' Excelの使用を開始する
    Call StartMSOfficeApp("Excel.Application", objExcelApp, g_objExcelAppShare)

If OPE_MODE = OPE_MODE__UNLOCK Then
    ' パスワードを解除して上書き保存する

    ' Excelでファイルを開く
    Set wbTargetFile = objExcelApp.Workbooks.Open(strFile, , , , strReadPassword, strWritePassword)

    ' パスワードを解除する
    wbTargetFile.Password = ""
    wbTargetFile.WritePassword = ""

ElseIf OPE_MODE = OPE_MODE__LOCK Then
    ' パスワードを設定して上書き保存する

    ' Excelでファイルを開く (パスワードがかかっている場合は個別に解除する)
    Set wbTargetFile = objExcelApp.Workbooks.Open(strFile)

    ' パスワードを設定する
    wbTargetFile.Password = strReadPassword
    wbTargetFile.WritePassword = strWritePassword

End If

    ' 読み取り専用で開かれた場合はエラーにする(上書きできないため)
    If wbTargetFile.ReadOnly = True Then
        ' 読み取り専用で開かれた旨をエラー通知する (No-Return)
        Call RaiseOpenWithReadOnlyError(strFile, "UpdatePasswordLockExcel)")
        Exit Sub        ' 到達しないが、念のため。
    End If

    ' 上書き保存する
    Call wbTargetFile.Save()

    ' ブックを閉じる
    Call wbTargetFile.Close()

    ' Excelの使用を終了する
    Call EndMSOfficeApp(objExcelApp)

    ' 参照を解放する
    ' メモ：ＭＳを信じれば(足を)すくわれる
    Set wbTargetFile = Nothing
    Set objExcelApp = Nothing

End Sub

Wordファイルのパスワードを設定/解除する

内容：Wordファイルを開いてパスワードを設定/解除し、上書き保存して閉じる。

パスワードを一括解除する.vbs

'***********************************************************
' パスワードを設定/解除して上書き保存する (Word)
'***********************************************************
Sub UpdatePasswordLockWord(strFile, strReadPassword, strWritePassword)
    Dim objWordApp
    Dim objTargetFile

    ' Wordの使用を開始する
    Call StartMSOfficeApp("Word.Application", objWordApp, g_objWordAppShare)

If OPE_MODE = OPE_MODE__UNLOCK Then
    ' パスワードを解除して上書き保存する

    ' Wordでファイルを開く
    Set objTargetFile = objWordApp.Documents.Open(strFile, , , , strReadPassword, , , strWritePassword)

    ' パスワードを解除する
    objTargetFile.Password = ""
    objTargetFile.WritePassword = ""

ElseIf OPE_MODE = OPE_MODE__LOCK Then
    ' パスワードを設定して上書き保存する

    ' Wordでファイルを開く (パスワードがかかっている場合は個別に解除する)
    Set objTargetFile = objWordApp.Documents.Open(strFile)

    ' パスワードを設定する
    objTargetFile.Password = strReadPassword
    objTargetFile.WritePassword = strWritePassword

End If

    ' 読み取り専用で開かれた場合はエラーにする(上書きできないため)
    If objTargetFile.ReadOnly = True Then
        ' 読み取り専用で開かれた旨をエラー通知する (No-Return)
        Call RaiseOpenWithReadOnlyError(strFile, "UpdatePasswordLockWord)")
        Exit Sub        ' 到達しないが、念のため。
    End If

    ' 上書き保存する
    Call objTargetFile.Save()

    ' ファイルを閉じる
    Const wdDoNotSaveChanges = 0        ' これを指定しないとWordが終了しない(ことが多い)
    Call objTargetFile.Close(wdDoNotSaveChanges)

    ' Wordの使用を終了する
    Call EndMSOfficeApp(objWordApp)

    ' 参照を解放する
    ' メモ：ＭＳを信じれば(足を)すくわれる
    Set objTargetFile = Nothing
    Set objWordApp = Nothing

End Sub

PowerPointファイルのパスワードを設定/解除する

内容：PowerPointファイルを開いてパスワードを設定/解除し、上書き保存して閉じる。

パスワードを一括解除する.vbs

Sub UpdatePasswordLockPowerpoint(strFile, strReadPassword, strWritePassword)
    Dim objPowerpointApp
    Dim objTargetFile

    ' Powerpointの使用を開始する
    Call StartMSOfficeApp("Powerpoint.Application", objPowerpointApp, g_objPowerpointAppShare)

If OPE_MODE = OPE_MODE__UNLOCK Then
    ' パスワードを解除して上書き保存する

    ' Powerpointでファイルを開く
    Set objTargetFile = objPowerpointApp.Presentations.Open(strFile & "::" & strReadPassword & "::" & strWritePassword)

    ' パスワードを解除する
    objTargetFile.Password = ""
    objTargetFile.WritePassword = ""

ElseIf OPE_MODE = OPE_MODE__LOCK Then
    ' パスワードを設定して上書き保存する

    ' Powerpointでファイルを開く (パスワードがかかっている場合は個別に解除する)
    Set objTargetFile = objPowerpointApp.Presentations.Open(strFile)

    ' パスワードを設定する
    objTargetFile.Password = strReadPassword
    objTargetFile.WritePassword = strWritePassword

End If

    ' 読み取り専用で開かれた場合はエラーにする(上書きできないため)
    If objTargetFile.ReadOnly = True Then
        ' 読み取り専用で開かれた旨をエラー通知する (No-Return)
        Call RaiseOpenWithReadOnlyError(strFile, "UpdatePasswordLockPowerpoint)")
        Exit Sub        ' 到達しないが、念のため。
    End If

    ' 上書き保存する
    Call objTargetFile.Save()

    ' ファイルを閉じる
    Call objTargetFile.Close()

    ' Powerpointの使用を終了する
    Call EndMSOfficeApp(objPowerpointApp)

    ' 参照を解放する
    ' メモ：ＭＳを信じれば(足を)すくわれる
    Set objTargetFile = Nothing
    Set objPowerpointApp = Nothing

End Sub

MS-Officeの使用を開始/終了する

■「FLG_REUSE_PROCESS=True」のとき
内容：初回実行時はMS-Officeを起動して返す。2回目以降は初回に起動したプロセスを返す。起動したプロセスはメイン関数で終了する。

■「FLG_REUSE_PROCESS=False」のとき
内容：実行毎にMS-Officeを起動して終了する。

パスワードを一括解除する.vbs

'***********************************************************
' MS-Officeの使用を開始する
'***********************************************************
Sub StartMSOfficeApp(strProgId, ref_objApp, ref_objAppShare)

If FLG_REUSE_PROCESS = True Then
    ' 1つのプロセスで複数のファイルを処理する場合

    ' 共用プロセスが無ければ新しいプロセスを開く
    If ref_objAppShare Is Nothing Then

        ' プロセスを起動
        Set ref_objAppShare = CreateObject(strProgId)

        ' プロセスのウィンドウを可視化
        ref_objAppShare.Visible = True
    End If

    ' 共用プロセスを使用
    Set ref_objApp = ref_objAppShare

Else
    ' ファイル毎にプロセスを分けて処理する場合

    ' プロセスを起動
    Set ref_objApp = CreateObject(strProgId)

    ' プロセスのウィンドウを可視化
    ref_objApp.Visible = True

End If

End Sub


'***********************************************************
' MS-Officeの使用を終了する
'***********************************************************
Sub EndMSOfficeApp(ref_objApp)

If FLG_REUSE_PROCESS = True Then
    ' 1つのプロセスで複数のファイルを処理する場合

    ' 共用プロセスは終了しない

Else
    ' ファイル毎にプロセスを分けて処理する場合

    ' プロセスを終了
    Call ref_objApp.Quit()

End If

End Sub

エラー通知

内容：想定されるエラーを発生する。

パスワードを一括解除する.vbs

'***********************************************************
' 非サポートの拡張子である旨をエラー通知する
'***********************************************************
Sub RaiseUnsupportedExtensionError(strFile, strFuncName)

    ' エラー番号は適当
    Call Err.Raise(vbObjectError + 1, _
            WScript.ScriptFullName & " (@" & strFuncName & ")", _
            "非対応の拡張子です：" + FSO.GetFileName(strFile))

End Sub


'***********************************************************
' 読み取り専用で開かれた旨をエラー通知する
'***********************************************************
Sub RaiseOpenWithReadOnlyError(strFile, strFuncName)

    ' エラー番号は適当
    Call Err.Raise(vbObjectError + 2, _
            WScript.ScriptFullName & " (@" & strFuncName & ")", _
            "読み取り専用で開かれました：" + FSO.GetFileName(strFile))

End Sub

処理結果のレポート出力

内容：処理結果をエクセル上に記録する。

パスワードを一括解除する.vbs

'***********************************************************
' レポートを出力
'***********************************************************
Sub WriteReport(opt_wsReport, strFile, ByVal LatchErr)

    If Not (opt_wsReport Is Nothing) Then

        ' レポート出力用のブックにフォーカスする
        Call opt_wsReport.Activate()

        ' ヘッダ行を出力する (1行目の場合のみ)
        If opt_wsReport.Application.Selection.Row = 1 Then
            ' (1列目) ファイル名
            opt_wsReport.Application.Selection = "ファイル"
            ' (2～5列目) エラー情報
            opt_wsReport.Application.Selection.Offset(0, 1) = "結果"
            opt_wsReport.Application.Selection.Offset(0, 2) = "Err.Number"
            opt_wsReport.Application.Selection.Offset(0, 3) = "Err.Description"
            opt_wsReport.Application.Selection.Offset(0, 4) = "Err.Source"
            ' フォーカスを次の行に移動
            opt_wsReport.Application.Selection.Offset(1, 0).Select
        End If

        ' ボディ行を出力する
        ' (1列目) ファイル名
        opt_wsReport.Application.Selection = strFile

        ' (2～5列目) エラー情報
        If LatchErr.Number = 0 Then
            opt_wsReport.Application.Selection.Offset(0, 1) = "成功"
            opt_wsReport.Application.Selection.Offset(0, 2) = LatchErr.Number
            opt_wsReport.Application.Selection.Offset(0, 3) = "-"
            opt_wsReport.Application.Selection.Offset(0, 4) = "-"
        Else
            opt_wsReport.Application.Selection.Offset(0, 1) = "失敗"
            opt_wsReport.Application.Selection.Offset(0, 2) = LatchErr.Number
            opt_wsReport.Application.Selection.Offset(0, 3) = LatchErr.Description
            opt_wsReport.Application.Selection.Offset(0, 4) = LatchErr.Source
        End If

        ' フォーカスを次の行に移動
        opt_wsReport.Application.Selection.Offset(1, 0).Select
    End If

End Sub

パスワード一括設定

パスワード一括解除を以下のように書き換えるだけ。

パスワードを一括設定する.vbs　(抜粋)

' コンパイルスイッチ
Const OPE_MODE                          = 2     ' OPE_MODE__LOCK