フォルダ内のエクセルファイルを全部ワンクリックでパスワード解除する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 | 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 |
パスワード解除するだけでなく、同時にエクセルファイルを読み取り専用に設定して保護する機能も入れています。
パスワードで保護してやりとりするようなエクセルファイルって、大事なデータが入ってて、誰かに上書きされたりして改変・消失するとマズイことが多いので。安易な上書きができないように読み取り専用に設定することができるようになっています。
コメント