トップ　>　汎用コード　>　パスワードの一括設定

読み取り・書き込みパスワードの一括設定

フォルダ内にあるExcelファイルに、読み取りパスワード、書き込みパスワードを一括で設定するマクロです。設定を変更すると、パスワードを一括で解除するような使い方も可能です。


【お薦め】マクロ・プロシージャを管理する無料のツール！
　Excelマクロ管理ツール

サンプルコード

コードの貼り付け場所 

'読み取り、書き込みの各conOld～とconNew～は定数
'conOldは現在ファイルに設定されているパスワード。conNewは新しく設定したいパスワード。
'パスワードの設定されていないファイルが対象の場合、conOldは""（空白）。
'既にパスワードの設定されているファイルが対象の場合はconOldにそのパスワードを入力。
'パスワードを解除する場合、conNewを""（空白）。
'読み取りパスワード（半角英数、最大15文字）
Private Const conOldRPW As String = ""
Private Const conNewRPW As String = "test"
'書き込みパスワード（半角英数、最大15文字）
Private Const conOldWPW As String = ""
Private Const conNewWPW As String = "test"


Sub Set_R_W_Password() 'メインマクロ。このマクロを実行する。
    Dim strDirPath As String, strExistDir As String
    strDirPath = Search_Directory()                 'フォルダの参照
    If Len(strDirPath) = 0 Then Exit Sub            '参照キャンセルならマクロ終了
    strExistDir = IsExistence_Directory(strDirPath) 'フォルダが存在するか確認
    If Len(strExistDir) = 0 Then Exit Sub           'フォルダがなければマクロ終了
    Call Password_Set_Module(strDirPath)            'パスワード一括設定へ
End Sub


Private Function Search_Directory() As String       'フォルダの参照
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function


Private Function IsExistence_Directory(ByVal DirPath As String) As String
    IsExistence_Directory = Dir(DirPath, vbDirectory) 'フォルダの存在確認
End Function


Private Sub Password_Set_Module(ByVal strPath As String) 'パスワードの一括設定
    Dim strTarget As String
    With Application
        strPath = strPath & .PathSeparator
        strTarget = Dir(strPath & "*.xls?")
        .ScreenUpdating = False
        .DisplayAlerts = False
        On Error Resume Next
            Do Until strTarget = ""
                With Workbooks.Open(strPath & strTarget, , , , conOldRPW, conOldWPW)
                    .SaveAs Filename:=strPath & strTarget, _
                    Password:=conNewRPW, WriteResPassword:=conNewWPW
                    .Close
                End With
                strTarget = Dir()
            Loop
        On Error GoTo 0
        .DisplayAlerts = True
        .ScreenUpdating = True
        strTarget = Dir("")
    End With
End Sub

定数を変更することで、パスワードの一括解除に対応します。
[conOldRPW]
　現在ファイルに設定されている読み取りパスワード。パスワードが設定されていなければ空白。
[conNewRPW]
　ファイルに新しく設定する読み取りパスワード。パスワードの設定を解除する場合は空白。
[conOldWPW]
　現在ファイルに設定されている書き込みパスワード。パスワードが設定されていなければ空白。
[conNewWPW]
　ファイルに新しく設定する書き込みパスワード。パスワードの設定を解除する場合は空白。

上記のマクロをそのまま実行すると、該当フォルダ内の全てのExcelファイルに、読み取りパスワード(test)、書き取りパスワード(test)が設定されます。
それらを一括で解除するには、conOldを"test"にし、conNewを""（空白）にし、再度マクロを実行します。

書籍紹介本を執筆しました

VBA好きに贈る　高速化の教科書
「あなたのマクロが激速化!!　Excel VBA 高速化　～観点と実践～」（Kindle版）
マクロの高速化と一口にいっても、ExcelやVBAの仕様や特性上のもの、システムデザインといった枠組みの考え方、プログラムのテクニックといったパートに大別できます。 それらの視点や考え方といった観点を整理しながら、実践につながるデザイン思考やテクニックに踏み込んでいます。

2021/4/15
「共有設定」のブックに対応したコードを追記します。ユーザー様から質問がありました。
共有設定ブックの場合、保存方法を変えてあります。他は同じです。 

'共有設定ブック対応版コード　2021/4/15　追記

'読み取り、書き込みの各conOld～とconNew～は定数
'conOldは現在ファイルに設定されているパスワード。conNewは新しく設定したいパスワード。
'パスワードの設定されていないファイルが対象の場合、conOldは""（空白）。
'既にパスワードの設定されているファイルが対象の場合はconOldにそのパスワードを入力。
'パスワードを解除する場合、conNewを""（空白）。
'読み取りパスワード（半角英数、最大15文字）
Private Const conOldRPW As String = ""
Private Const conNewRPW As String = "test"
'書き込みパスワード（半角英数、最大15文字）
Private Const conOldWPW As String = ""
Private Const conNewWPW As String = "test"


Sub Set_R_W_Password() 'メインマクロ。このマクロを実行する。
    Dim strDirPath As String, strExistDir As String
    strDirPath = Search_Directory()                 'フォルダの参照
    If Len(strDirPath) = 0 Then Exit Sub            '参照キャンセルならマクロ終了
    strExistDir = IsExistence_Directory(strDirPath) 'フォルダが存在するか確認
    If Len(strExistDir) = 0 Then Exit Sub           'フォルダがなければマクロ終了
    Call Password_Set_Module(strDirPath)            'パスワード一括設定へ
End Sub


Private Function Search_Directory() As String       'フォルダの参照
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function


Private Function IsExistence_Directory(ByVal DirPath As String) As String
    IsExistence_Directory = Dir(DirPath, vbDirectory) 'フォルダの存在確認
End Function


Private Sub Password_Set_Module(ByVal strPath As String) 'パスワードの一括設定
    Dim strTarget As String
    With Application
        strPath = strPath & .PathSeparator
        strTarget = Dir(strPath & "*.xls?")
        .ScreenUpdating = False
        .DisplayAlerts = False
        On Error Resume Next
            Do Until strTarget = ""
                With Workbooks.Open(strPath & strTarget, , , , conOldRPW, conOldWPW)
                    If .MultiUserEditing Then '共有確認　共有パスワードを設定している場合は"1234"を書き換え
                        .UnprotectSharing 'Sharingpassword:="1234"
                        .ExclusiveAccess
                        .SaveAs Filename:=strPath & strTarget, _
                        Password:=conNewRPW, WriteResPassword:=conNewWPW
                        .SaveAs Filename:=strPath & strTarget, _
                        accessMode:=xlShared
                    Else
                        .SaveAs Filename:=strPath & strTarget, _
                        Password:=conNewRPW, WriteResPassword:=conNewWPW
                    End If
                    .Close
                End With
                strTarget = Dir()
            Loop
        On Error GoTo 0
        .DisplayAlerts = True
        .ScreenUpdating = True
        strTarget = Dir("")
    End With
End Sub

ページトップへ戻る

Excel 汎用コード



Word 汎用コード

Copyright(C) 2009- 坂江 保 All Rights Reserved.