テスト81

```vb
Option Compare Database
Option Explicit

'Accessファイル
Function test1()
'-------------------------------------
'このプロシージャをAutoExecで設定
'排他モードでもAccessファイルを開くと自動で自身をバックアップする
'(正確にはExcelにバックアップしてもらう)....〆(･ω･。)
'参照設定：Microsoft ActiveX Data Objects 6.1 Library
'-------------------------------------
'自身のAccessファイルが排他モードでも自動でバックする処理
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim Ex As Variant

If DLookup("日付", "T_バックアップ用日付") = Date Then Exit Function

Set cn = CurrentProject.Connection
Set rs = New ADODB.Recordset

'レコードセットを取得
rs.Open "T_バックアップ用日付", cn, adOpenKeyset, adLockOptimistic
rs.MoveFirst
rs!日付 = Date

rs.Update
rs.Close: cn.Close
Set rs = Nothing: Set cn = Nothing

DoCmd.Save

Set Ex = CreateObject("Excel.Application")
Ex.visible = True
Ex.screenupdating = False
Ex.workbooks.Open ("C:\Users\User\Desktop\VBA関連\AccessVBA学習\バックアップ用ファイル.xlsm")
Ex.Run "バックアップ用ファイル.xlsm!backup2"

End Function

'-------------------------------------------

'Excelファイル
Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private FSO As Variant

Sub backup2()

Dim str As String
Dim appAccess As Variant

'Accessを強制終了させる
Shell "taskkill /F /IM MSAccess.exe"

Call backup3

str = "C:\Users\User\Desktop\VBA関連\AccessVBA学習\練習用.accdb"

Set appAccess = CreateObject("Access.Application")
appAccess.Visible = True

'指定のAccessファイルを開く
appAccess.OpenCurrentDatabase str

'Excelを閉じる
Application.Quit

End Sub


Public Sub backup3()

'テスト79とテスト80の問題を一気に解決する方法
'排他モードでも自身のAccessファイルをコピーできる

Dim tmp As String
Dim File_Path1 As String
Dim Fol_Path As String
Dim File_Path2 As String
Dim WshShell As Variant
Dim str As String

Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")

File_Path1 = "C:\Users\User\Desktop\VBA関連\AccessVBA学習\練習用.accdb"

'バックアップ先のフォルダパス
Fol_Path = "C:\Users\User\Desktop\VBA関連\AccessVBA学習\バックアップ"

'バックアップ時に出力するファイル名
tmp = Format(Now, "yyyymmddhhmmss") & FSO.GetFileName(File_Path1)

'バックアップ時ファイルパスを作成
File_Path2 = FSO.BuildPath(Fol_Path, tmp)

'出力先フォルダ内の指定のファイル数のチェック
'5個以上あったら、作成時間の遅いファイルから削除
Call Del_File(Fol_Path)

Sleep 1000
'バックアップ
FSO.Copyfile File_Path1, File_Path2
Set WshShell = Nothing
Set FSO = Nothing


End Sub


Public Sub Del_File(ByVal Fol_Path As String)
'------------------------------------------------------------------
'DictionaryをKeyの昇順に並び替える。
'------------------------------------------------------------------
Dim i As Long
Dim AryList As Object
Dim KeyItem As String
Dim temp As Variant
Dim file As Variant
Dim dic As Variant
Dim curKey As Variant
Dim tmp2 As Variant

Set dic = CreateObject("Scripting.Dictionary")

For Each file In FSO.GetFolder(Fol_Path).Files

    If InStr(FSO.GetFileName(file), "練習用") > 0 Then
        'キーにファイルの作成日時、値にファイルパスを格納
        dic.Add file.DateCreated, file.Path
    
    End If
    
Next file

'.NET FrameworkのArrayListクラスを利用する
Set AryList = CreateObject("System.Collections.ArrayList")

'dicに入れたデータをArrayListに移す。
For Each curKey In dic

    If curKey <> "" Then
        '日付日時とファイルパスを格納
        KeyItem = curKey & "_" & dic(curKey)
        AryList.Add KeyItem
    
    End If
    
Next curKey

'昇順にする
AryList.Sort

'削除する
dic.RemoveAll

'もう一度入れなおす。
For i = 0 To AryList.Count - 1
    temp = Split(AryList(i), "_")
    dic(temp(0)) = temp(1)
Next i


'指定のファイルが5個以上だった場合
If dic.Count >= 5 Then

    i = dic.Count
    '古いファイルから6個目移行を削除
    For Each tmp2 In dic
    
        If i >= 5 Then
            DoEvents
            Kill dic(tmp2)
            DoEvents
        Else
            '古い順からファイルを削除し、5個になったら離脱
            Exit For
        
        End If
        
        i = i - 1
        
    Next tmp2

End If

Set AryList = Nothing

End Sub