OneDrive上のEXCELに直接パスワードをつけるマクロがうまくいかない時の対処法

この前我輩の元へマクロの相談が来た。その人はエンジニアとまでいかないが、EXCELでそれなりのマクロをかけるシゴデキ人間だ。

作りたいマクロはこんな感じ。

1. ディレクトリを指定する
2. パスワードを指定する
3. ディレクトリ内のEXCELファイルが全部パスワードついてる！！！！！

というものだ。実にシンプルだが、正直大抵のエンジニアであれば、マクロでやるべきことではないのはわかるだろう。普通にrarファイルでパス付きで暗号化した方が確実だし高速だ。
セキュリティ上ローカルディレクトリに落とさせたくないという要望があったとしても、Sharepointでパス付きで共有するとかなんとでもなるような気がするが、まあいいだろう。

とりあえず、ネットに落ちてた結構可読性の高いものを使うことにした。

https://excel.syogyoumujou.com/vba/set_password.html

しかし、事態は最悪の展開を迎えた。
正常にパスワードがついていない。だが、一切のエラーが出ない。
これだけエラーハンドリングが施されているにも関わらず、エラーが出ないというのは妙だ。
試しにデバッグとして処理中のファイル名を出力させても、正常に動作しているように思える。

ここで私の中で以下のような仮説が立った。

• OneDriveもEXCELもMSだよな？当然OneDrive上にEXCELファイル作ったら共有しやすいとか、バックアップ取ってくれるとかMSだったらやりそうだな。
• 当たり前だが、パスワードがつくと暗号化される。外部のマクロによる影響をデータの破壊だとみなされる？
• 最終更新日が変更されてないし、なんか開く時妙に遅い。ロールバックみたいな処理が走ってる？

というわけで普通にOnedriveのパスの外に保存してやってみたら、普通にできた。やったぜ。
次に、ロールバック？対策のためにファイル名を変えて別で保存してみる。
結論からいって、これは成功した。

つまり、直接更新はできないが、ファイルの作成はできる。てなわけでこんな感じに改変してみた。

tmpという一時ディレクトリを作成する
この中に、元のファイル名で暗号化したファイルを保存。
一個ファイルを保存するたび、元のデータをないないする。
で、最後に一時ファイル内から全部元のディレクトリに移動して、
tmpファイルをないないする。

注意：
すでにディレクトリ内にtmpというディレクトリが存在する場合予期せぬ結果が起きそうだから、要注意だ。

てなわけで、改変！
念の為、サフィックスを格納する定数も追加しておく。空白でも動作するようにしよう。

Private Const conOldRPW As String = ""
Private Const conNewRPW As String = "test"
Private Const conOldWPW As String = ""
Private Const conNewWPW As String = "test"

Private Const PASSWORD_SET_SUFFIX As String = ""

Sub Set_R_W_Password() 'メインマクロ。このマクロを実行する。
    Dim strDirPath As String, strExistDir As String
    strDirPath = Search_Directory()                 'フォルダの参照
    If Len(strDirPath) = 0 Then Exit Sub            '参照キャンセルならマクロ終了
    strExistDir = IsExistence_Directory(strDirPath) 'フォルダが存在するか確認
    If Len(strExistDir) = 0 Then Exit Sub           'フォルダがなければマクロ終了
    Call Password_Set_Module(strDirPath)            'パスワード一括設定へ
End Sub

Private Function Search_Directory() As String       'フォルダの参照
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Private Function IsExistence_Directory(ByVal DirPath As String) As String
    IsExistence_Directory = Dir(DirPath, vbDirectory) 'フォルダの存在確認
End Function

Private Sub Password_Set_Module(ByVal strPath As String) 'パスワードの一括設定
    Dim strTarget As String
    Dim outputDir As String
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    ' 出力用ディレクトリのパスを設定
    outputDir = strPath & Application.PathSeparator & "Output"
   
    ' 出力用ディレクトリが存在しない場合は作成
    If Not fso.FolderExists(outputDir) Then
        fso.CreateFolder outputDir
    End If
   
    With Application
        strPath = strPath & .PathSeparator
        strTarget = Dir(strPath & "*.xls?")
        .ScreenUpdating = False
        .DisplayAlerts = False
        Do Until strTarget = ""
            Debug.Print "Processing: " & strPath & strTarget ' デバッグ用出力
            With Workbooks.Open(strPath & strTarget, , , , conOldRPW, conOldWPW)
                Dim newFileName As String
                ' パスワード設定済みのファイル名を作成
                newFileName = Replace(strTarget, ".xls", PASSWORD_SET_SUFFIX & ".xls")
               
                ' 出力用ディレクトリに同じ名前で保存
                If .MultiUserEditing Then
                    .UnprotectSharing
                    .ExclusiveAccess
                    .SaveAs Filename:=outputDir & Application.PathSeparator & newFileName, _
                    Password:=conNewRPW, WriteResPassword:=conNewWPW
                    .SaveAs Filename:=outputDir & Application.PathSeparator & newFileName, _
                    accessMode:=xlShared
                Else
                    .SaveAs Filename:=outputDir & Application.PathSeparator & newFileName, _
                    Password:=conNewRPW, WriteResPassword:=conNewWPW
                End If
                .Close
            End With
            ' 元のファイルを削除
            Call DeleteOriginalFile(strPath & strTarget)
            ' 暗号化したファイルを元のディレクトリに移動
            Call MoveEncryptedFile(outputDir & Application.PathSeparator & newFileName, strPath & newFileName)
            strTarget = Dir()
        Loop
        .DisplayAlerts = True
        .ScreenUpdating = True
        strTarget = Dir("")
    End With
   
    ' 出力用ディレクトリを削除
    Call DeleteOutputDirectory(outputDir)
End Sub

Private Sub DeleteOriginalFile(ByVal filePath As String)
    On Error Resume Next ' エラーが発生しても続行
    Kill filePath
    On Error GoTo 0 ' エラーハンドリングを元に戻す
End Sub

Private Sub MoveEncryptedFile(ByVal sourcePath As String, ByVal destPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next ' エラーが発生しても続行
    fso.MoveFile sourcePath, destPath
    On Error GoTo 0 ' エラーハンドリングを元に戻す
End Sub

Private Sub DeleteOutputDirectory(ByVal dirPath As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next ' エラーが発生しても続行
    fso.DeleteFolder dirPath, True
    On Error GoTo 0 ' エラーハンドリングを元に戻す
End Sub

正常に動作する。以上！閉廷！みんな解散！

業務命令で作ったわけじゃないしベースが公開されているものなので、これが機密情報になることはないだろうが、念の為変数名とか色々変えてるぞ！安心せい！