You Look Too Cool

Sub 複数ファイルパスワード操作()
    'フォルダ内の共通のパスワードがセットされた文書を連続して開き、解除して上書き保存。
    '逆にフォルダ内の文書を連続して開き、共通のパスワードをセットして上書き保存。
    Dim onoff As Long
    Dim mypw, pwopen, pwclose, mypath, myfn As String
    '操作を選択
    onoff = MsgBox("パスワード解除ならば「はい」、セットならば「いいえ」", vbYesNo)
    If onoff = vbCancel Then
        Exit Sub
    End If
    'パスワードをセット
    mypw = InputBox("パスワードを入力。", "パスワード")
    If onoff = vbYes Then
        pwopen = mypw
        pwclose = ""
    ElseIf onoff = vbNo Then
        pwopen = ""
        pwclose = mypw
    Else
        Exit Sub
    End If
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択"
        .AllowMultiSelect = False
        If .Show = -1 Then
            mypath = .SelectedItems(1) & ""
        Else
            Exit Sub
        End If
    End With
    'ファイルの取得と実行
    myfn = Dir(mypath & "\*.doc*", vbNormal)
    Do Until myfn = ""
        '開く
        Documents.Open FileName:=mypath & myfn, PasswordDocument:=pwopen
        '文末に改行を挿入し削除(何らかの変更がないと上書き保存できない)
        Selection.EndKey Unit:=wdStory
        Selection.TypeParagraph
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.Delete Unit:=wdCharacter, Count:=1
        '上書き保存
        ActiveDocument.SaveAs FileName:=ActiveDocument.FullName, Password:=pwclose, WritePassword:=""
        ActiveWindow.Close
        myfn = Dir
    Loop
End Sub

Sub 複数ファイルパスワード操作()
    Dim myfolder, myfn, myword, pwopen, pwclose
    Dim pattern
    '操作を選択
    pattern = MsgBox("パスワード解除ならば「はい」、セットならば「いいえ」", vbYesNo)
    If pattern = vbCancel Then
        Exit Sub
    End If
    'パスワードをセット
    myword = InputBox("パスワードを入力。")
    If pattern = vbYes Then
        pwopen = myword
        pwclose = ""
    ElseIf pattern = vbNo Then
        pwopen = ""
        pwclose = myword
    End If
    'フォルダを選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "操作したいファイルのあるフォルダを選択"
        .AllowMultiSelect = False
        If .Show = -1 Then
            myfolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    'ファイルを操作
    myfn = Dir(myfolder & "\*.xls", vbNormal)
    Do Until myfn = ""
        Call ファイル開閉(myfolder & "" & myfn, pwopen, pwclose)
        myfn = Dir
    Loop
End Sub

Function ファイル開閉(myfn, pwopen, pwclose)
    Workbooks.Open Filename:=myfn, Password:=pwopen
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=myfn, Password:=pwclose, WriteResPassword:=""
    Application.DisplayAlerts = True
    ActiveWorkbook.Close
End Function