ファイル削除

zip圧縮に続いて、今度はフォルダを削除するスクリプト。
関数の為、以下の様に呼び出して使います。
Call OldFileDelete("C:¥Temp", 7)


 ■指定フォルダの指定日数分を残してファイルを削除する

Sub OldFileDelete(strFolder, numDays) 
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")

Dim MyFolder
Set MyFolder = objFSO.GetFolder(strFolder)

Dim MyFileName
For Each MyFileName In MyFolder.Files
If DateDiff("d", MyFileName.DateLastModified, date) >= numDays Then
On Error Resume Next
objFSO.DeleteFile MyFileName
On Error Goto 0
End If
Next

Set MyFileName = Nothing
Set MyFolder = Nothing
Set objFSO = Nothing
End Sub

■指定フォルダの指定個数分最新のものを残してファイルを削除する関数

Sub OldFileDelete2(strFolder, numDays)
Dim rs
Set rs = CreateObject("ADODB.Recordset")
Call rs.Fields.Append("LastModified", 4)
Call rs.Fields.Append("FileName", 130, 1000)
Call rs.Open()

Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")

Dim MyFolder
Set MyFolder = objFSO.GetFolder(strFolder)

Dim WshShell
set WshShell = WScript.CreateObject("WScript.Shell")

Dim objShortcut

Dim MyFileName
For Each MyFileName In MyFolder.Files

On Error Resume Next
Set objShortcut = WshShell.CreateShortcut(strFolder &"\"& MyFileName.Name)
' LNKファイル以外はエラーとなる（index.dat を除外）
If Err.Number = 0  Then
On Error Goto 0

If objFSO.FolderExists(objShortcut.TargetPath) Then
On Error Resume Next
' リンク先がフォルダであればリンクファイルを削除
objFSO.DeleteFile strFolder &"\"& MyFileName.Name
On Error Goto 0
ElseIf objFSO.FileExists(objShortcut.TargetPath) Then
Call rs.AddNew()
rs.Fields("FileName").Value = MyFileName.Name
rs.Fields("LastModified").Value = MyFileName.DateLastModified
Call rs.Update()
Else
' リンク先がリンク切れフォルダまたはリンク切れファイルであればリンクファイルを削除
On Error Resume Next
objFSO.DeleteFile strFolder &"\"& MyFileName.Name
On Error Goto 0
End If

Else
On Error Goto 0
' WScript.Echo strFolder &"\"& MyFileName.Name
End If

Next

rs.Sort = "LastModified DESC"

If rs.RecordCount > numDays Then
Call rs.Move(numDays)
Do Until rs.EOF
On Error Resume Next
objFSO.DeleteFile strFolder &"\"& rs.Fields("FileName").Value
On Error Goto 0
rs.MoveNext
Loop
End If

Call rs.Close()

Set MyFileName = Nothing
Set MyFolder = Nothing
Set objFSO = Nothing
Set rs = Nothing
End Sub