【ExcelVBA】タイムスタンプを変えずにパスワード設定を行う

スポンサーリンク

Excelファイルのタイムスタンプを変更したくない時ってありませんか?
パスワードを付け忘れたり、付けなくてもよかったのにPWを付けてしまった場合、変更するためにはファイルを開いて変更する必要があります。でも、ファイルを開いて変更後に保存する場合は、保存時のタイムスタンプとなってしまいます

今回は、VBAでパスワードの設定を変更する処理について、タイムスタンプを変更しないで行う方法について紹介します

Excelファイルのパスワード変更をタイムスタンプを変えずにVBAで実行する方法について

スポンサーリンク

タイムスタンプにアクセスするための設定

FileSystemObjectとは

FileSystemObjectとは、ファイルシステムへアクセスするメソッドなどを提供するオブジェクトのことです。ファイルをコピーする「CopyFile」やフォルダをコピーする「CopyFolder」メソッドなど、ファイルやフォルダシステムにアクセスするためには、このオブジェクトを参照設定する必要があります

FileSystemObjectを使うための準備

FileSystemObjectの参照設定を行う

VBE(Visual Basic Editor)から、メニューの「ツール→参照設定」とたどり、「参照可能なライブラリファイル」から「Microsoft Scripting Runtime」にチェックを付けて「OK」ボタンをクリックします

タイムスタンプを変更しないための処理方法

ファイルを開く際に、タイムスタンプに関する情報を取得します。取得できる情報は
・DateCreated ‘ 作成日時を取得
・DateLastModified ‘ 更新日時を取得
・DateLastAccessed ‘ アクセス日時を取得
ですが、2番目の「DateLastModified」 更新日時を取得して関数に保存しておきます

そして、パスワード変更後にファイルを保存してから、Shell.Applicationを使って保存したファイルにアクセスして更新日時を書き換える処理を行っています(これは、FileSystemObjectでは更新日時を取得はできますが書き換える処理はできないためShellを使っているということです)

Excelシートの設定

・VBAマクロを登録して実行させるためのボタンを二つ配置
PWを設定するためのセルは「E16」「E18」です
サンプルファイルがありますので是非ご利用ください

タイムスタンプを変えずにPW設定を行うVBAコード

フォルダ内の全ファイル書き換え用コード

Sub PWフォルダ設定()

    Range("E6") = ""
    Range("E8") = ""
    MsgBox ("対象フォルダを指定してください!")
    Call selectFolder
    If Range("E6") = "" Then MsgBox ("処理を中止します!"): Exit Sub
    
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject

    Dim fl As Folder
    Set fl = fso.getFOLDER(Range("E6") & "\") 'フォルダを取得

    Dim f As File
    Dim d As Date
    Dim PW As String
    Dim SetPW As String
    
    Call マクロ開始

    PW = Range("E16")
    SetPW = Range("E18")
    
    Dim shell As Object
    Dim fl2 As Object
    Dim f2 As Object

    For Each f In fl.Files 'フォルダ内のファイルを取得
        If Left(f.Type, 15) <> "Microsoft Excel" Then
            GoTo nextloop   'Excelファイル以外は処理しない
        End If
        d = f.DateLastModified '更新日時を取得
        'PWを変更して保存
        Workbooks.Open fileName:=f, Password:=PW, UpdateLinks:=0
        ActiveWorkbook.SaveAs fileName:=f, Password:=SetPW
        Workbooks(f.Name).Close Savechanges:=True
    
        Set shell = CreateObject("Shell.Application") 'インスタンス化
        Set fl2 = shell.Namespace(Range("E6") & "\") 'フォルダを取得
        Set f2 = fl2.ParseName(f.Name) 'フォルダ内のファイルを取得
        
        f2.ModifyDate = d '更新日時を書き換える(元に戻す)
nextloop:
        Set f2 = Nothing
        Set fl2 = Nothing
        Set shell = Nothing
    Next
    
    Set f = Nothing
    Set fl = Nothing
    Set fso = Nothing
    
    Call マクロ終了
    If Range("E18") <> "" Then
        MsgBox ("パスワードをすべて変更しました!")
    Else
        MsgBox ("パスワードをすべて解除しました!")
    End If
End Sub

・「フォルダ選択」後、フォルダ内のすべてのファイルに対してループ処理します
・途中、Excelファイル以外があった場合は処理を除外しています
・ファイルを開く前にタイムスタンプを変数に保存します
・ファイルを開いてパスワードを設定して変更を保存して閉じます
閉じたファイルをShellからアクセスしてタイムスタンプを書き換えます
※ 次の選択ファイルの処理も基本的には同じ処理です

選択ファイルだけ書き換えるコード

Sub PW選択ファイルを設定()
    Dim sfileName As String
    Dim boolRes As Boolean
    Range("E6") = ""
    Range("E8") = ""
    
    With Application.FileDialog(msoFileDialogOpen) '複数選択可で表示
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xls*"
        .Title = "ファイルを指定して下さい"
        .AllowMultiSelect = True
        boolRes = .Show
        If boolRes = False Then MsgBox "処理を中止します!": Exit Sub
        sfileName = .SelectedItems(1)
        '選択ファイルの結果表示
        Range("E8") = Dir(sfileName) '最初のファイル名
        Range("E6") = Left(sfileName, InStrRev(sfileName, "\")) 'フォルダ
        
        Dim fso As FileSystemObject
        Set fso = New FileSystemObject
        Dim fl As Folder
        Set fl = fso.getFOLDER(Range("E6"))  'フォルダを取得
        
        Dim f As File
        Dim d As Date
        Dim PW As String: PW = Range("E16")
        Dim SetPW As String: SetPW = Range("E18")
    
        Call マクロ開始
    
        Dim shell As Object
        Dim fl2 As Object
        Dim f2 As Object
        Dim i As Long
        For i = 1 To .SelectedItems.Count 'fl.Files  'フォルダ内のファイルを取得
            sfileName = .SelectedItems(i)
            If i > 1 Then Range("E8") = Dir(sfileName) 'ファイル名変更
            Set f = fso.GetFile(sfileName)
            If Left(f.Type, 15) <> "Microsoft Excel" Then
                GoTo nextloop   'Excelファイル以外は処理しない
            End If
            d = f.DateLastModified      '更新日時を取得
            'ファイルを開きパスワードを設定してファイルを保存して閉じる
            Workbooks.Open fileName:=f, Password:=PW, WriteResPassword:=PW, UpdateLinks:=0
            ActiveWorkbook.SaveAs fileName:=f, Password:=SetPW
            Workbooks(f.Name).Close Savechanges:=True
    
            Set shell = CreateObject("Shell.Application") 'インスタンス化
            Set fl2 = shell.Namespace(fl & "\") 'フォルダを取得
            Set f2 = fl2.ParseName(f.Name)      'フォルダ内のファイルを取得
            
            f2.ModifyDate = d           '更新日時を書き換える(元に戻す)
nextloop:
            Set f = Nothing
            Set f2 = Nothing
            Set fl2 = Nothing
            Set shell = Nothing
        Next
    End With
    Set fl = Nothing
    Set fso = Nothing
    
    Call マクロ終了
    
    If Range("E18") <> "" Then
        MsgBox ("パスワードをすべて変更しました!")
    Else
        MsgBox ("パスワードをすべて解除しました!")
    End If
End Sub

フォルダ選択ダイアログ表示用のコード

Sub selectFolder()
    Dim strWORK As String
    strWORK = getFOLD()  'フォルダー選択関数
    Range("E6").Formula = strWORK
End Sub

'フォルダー選択関数(ダイアログを表示)
Function getFOLD() As String
    Dim dlg As FileDialog

    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時
    If dlg.Show = False Then
        getFOLD = ""
        Exit Function
    End If
    ' フォルダーのフルパスを変数に格納
    getFOLD = dlg.SelectedItems(1)
End Function

フォルダダイアログの処理コードは今までの使いまわしですね(^^)

まとめ(おわりに)

基本事項の確認と感想など

・Excelファイルだけに対する処理ですので、他の種類のファイルには対応していません
・Excel以外のファイルが選択された場合は、処理をパスするように設定していますが注意してください(必要に応じて、実行前にバックアップを取るなどで対応願います

・パスワードの付け忘れや、パスワードをまとめて変更したい場合に便利です
パスワードを一括で外すことにも使えます(空欄で実行すればOK)
・タイムスタンプの処理(変更しない)が不要ならば、その部分のコードをコメントアウトするか、要不要の判定処理をプラスすればOKです

今後の記事について

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです(^^;
是非!サンプルがありますので使ってみてください(^^)/
「小ネタ」でタイムスタンプの変更部分だけでもう一つ記事にしておこうかなぁ(^^)


【今後の記事内容はどうしようかなぁ・・・】
・ZIPファイルの作成方法と活用法など
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・その他「小ネタ」などなど・・・・・
・今後これらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください