フォルダ内のエクセルファイルを全部ワンクリックでパスワード解除するVBAです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
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 |
パスワード解除するだけでなく、同時にエクセルファイルを読み取り専用に設定して保護する機能も入れています。
パスワードで保護してやりとりするようなエクセルファイルって、大事なデータが入ってて、誰かに上書きされたりして改変・消失するとマズイことが多いので。安易な上書きができないように読み取り専用に設定することができるようになっています。
コメント