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
VBA
コメント