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

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

フォルダ内にある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.