フォルダ内のエクセルファイルを一括パスワード解除する！

フォルダ内のエクセルファイルを全部ワンクリックでパスワード解除するVBAです。

Sub xls_release_pw_in_this_folder()
    Dim rOnly As Integer
    Dim myFn As String
    Dim pw As String
    Dim wb As Workbook '以上変数宣言
    pw = InputBox("解除する読み取りパスワードを入力してください。")
    If StrPtr(pw) = 0 Then
        Exit Sub
    End If
    rOnly = MsgBox("ついでに読み取り専用に設定しますか？（推奨：Yes >> 誤った上書き等の防止のため）", vbYesNoCancel)
    If rOnly = 2 Then
        Exit Sub 'キャンセルなら中止
    End If
    rOnly = 7 - rOnly
    Application.ScreenUpdating = False '更新停止
    myFn = Dir(ThisWorkbook.Path & "\*.xls?") 'エクセルファイルを探す
    Do While myFn <> ""
        If myFn <> ThisWorkbook.Name Then 'ファイル名がこのファイルの名前と異なる場合
            SetAttr ThisWorkbook.Path & "\" & myFn, 0 '一旦属性をNomalに戻す
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myFn, passWord:=pw, ReadOnly:=0, ignorereadonlyrecommended:=1)  '開く
            With wb
                Application.DisplayAlerts = False '警告停止
                .SaveAs Filename:=wb.FullName, passWord:="" 'パスワードなしで上書保存
                .Close False '閉じる
                Application.DisplayAlerts = True '警告停止解除
            End With
            SetAttr ThisWorkbook.Path & "\" & myFn, rOnly '属性を読み取り専用に設定（rOnly：yesのcaseのみ）
        End If
        myFn = Dir()
    Loop
    Application.ScreenUpdating = True '更新停止解除
    MsgBox "完了"
End Sub

Subxls_release_pw_in_this_folder()

DimrOnlyAsInteger

DimmyFnAsString

DimpwAsString

DimwbAsWorkbook'以上変数宣言

pw=InputBox("解除する読み取りパスワードを入力してください。")

IfStrPtr(pw)=0Then

ExitSub

EndIf

rOnly=MsgBox("ついでに読み取り専用に設定しますか？（推奨：Yes >> 誤った上書き等の防止のため）",vbYesNoCancel)

IfrOnly=2Then

ExitSub'キャンセルなら中止

EndIf

rOnly=7-rOnly

Application.ScreenUpdating=False'更新停止

myFn=Dir(ThisWorkbook.Path&"\*.xls?")'エクセルファイルを探す

DoWhilemyFn<>""

IfmyFn<>ThisWorkbook.NameThen'ファイル名がこのファイルの名前と異なる場合

SetAttrThisWorkbook.Path&"\" & myFn, 0 '一旦属性をNomalに戻す

Set wb = Workbooks.Open(ThisWorkbook.Path & "\"&myFn,passWord:=pw,ReadOnly:=0,ignorereadonlyrecommended:=1) '開く

Withwb

Application.DisplayAlerts=False'警告停止

.SaveAsFilename:=wb.FullName,passWord:=""'パスワードなしで上書保存

.CloseFalse'閉じる

Application.DisplayAlerts=True'警告停止解除

EndWith

SetAttrThisWorkbook.Path&"\" & myFn, rOnly '属性を読み取り専用に設定（rOnly：yesのcaseのみ）

End If

myFn = Dir()

Loop

Application.ScreenUpdating = True '更新停止解除

MsgBox "完了"

EndSub

パスワード解除するだけでなく、同時にエクセルファイルを読み取り専用に設定して保護する機能も入れています。

パスワードで保護してやりとりするようなエクセルファイルって、大事なデータが入ってて、誰かに上書きされたりして改変・消失するとマズイことが多いので。安易な上書きができないように読み取り専用に設定することができるようになっています。