gpedit.mscでシャットダウンスクリプト（ごみ箱空にする、デスクトップ等のファイル削除、お気に入りのリセット）を行うVBSを登録しました。
単体では動作しますが、シャットダウン時スクリプトが実行されると「パスが見つかりません」エラー(800A004C)が出ます。
ファイル削除時のパスが取得できないのだと思いますが、対策が分かりません。
以下ソースです。原因についてアドバイスお願いいたします。
Option Explicit
Dim strUserName
Dim aryDir(8)
Dim aryExtension(8)
Dim i
Dim strExtValue
Dim FSO
Dim Shell
Dim baseFolder
Dim tempFile
Dim tempFolder
Dim subfolder
Dim subfolder2
Dim strBatchPath
Dim Folder
Dim sFolder
Dim FolderItem
Dim strCopyFrom
Dim strCopyTo
strUserName = WScript.CreateObject("WScript.Network").UserName
'↓↓削除する場所↓↓
aryDir(0) = "C:\Users\" & strUserName & "\Desktop\"
aryDir(1) = "C:\Users\" & strUserName & "\OneDrive\"
aryDir(2) = "C:\Users\" & strUserName & "\Videos\"
aryDir(3) = "C:\Users\" & strUserName & "\Music\"
aryDir(4) = "C:\Users\" & strUserName & "\Downloads\"
aryDir(5) = "C:\Users\" & strUserName & "\Documents\"
aryDir(6) = "C:\Users\" & strUserName & "\Pictures\"
aryDir(7) = "C:\Scan\"
aryDir(8) = "C:\Users\" & strUserName & "\AppData\Roaming\Microsoft\Windows\Recent\"'履歴は最後に消す必要あり(本VBSが履歴に残るため)
'↑↑削除する場所↑↑
'↓↓削除しない拡張子 拡張子をセミコロン区切りで記述↓↓
aryExtension(0) = "lnk"
aryExtension(1) = "*"
aryExtension(2) = "*"
aryExtension(3) = "*"
aryExtension(4) = "*"
aryExtension(5) = "*"
aryExtension(6) = "*"
aryExtension(7) = "*"
aryExtension(8) = "*"
'↑↑削除しない拡張子 拡張子をセミコロン区切りで記述↑↑
'↓↓お気に入りのコピー元・コピー先↓↓
strCopyFrom = "コピー元ディレクトリ(サーバーにFavoritesディレクトリを置いてフォルダ毎コピーしています)"
strCopyTo = "C:\Users\" & strUserName & "\"
'↑↑お気に入りのコピー元・コピー先↑↑
'↓↓↓ゴミ箱を空にする↓↓↓
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.NameSpace(10)
For Each FolderItem In Folder.Items()
If FSO.FileExists(FolderItem.Path) Then
FSO.DeleteFile FolderItem.Path,True
ElseIf FSO.FolderExists(FolderItem.Path) Then
FSO.DeleteFolder FolderItem.Path,True
End If
Next
If Folder.Items().Count=0 Then
Set sFolder=Shell.NameSpace(FSO.GetParentFolderName(WScript.ScriptFullName))
Folder.MoveHere sFolder.Items().Item(WScript.ScriptName)
Do While Not sFolder.Items().Item(WScript.ScriptName) Is Nothing
WScript.Sleep 100
Loop
sFolder.MoveHere Folder.Items().Item(0)
End If
'↑↑↑ゴミ箱を空にする↑↑↑
'お気に入りファイルの初期化
'コピー元フォルダが存在しているときのみファイル削除とコピーを行う
If FSO.FolderExists(strCopyFrom) Then
Call deleteFiles(strCopyTo, "lnk")
Call Delete0Dir(strCopyTo)
Call FileCopy(strCopyFrom, strCopyTo)
End If
For i = 0 To UBound(aryDir)
Call deleteFiles(aryDir(i), aryExtension(i))
Next
'Call WScript.Echo("ファイル削除が完了しました。", vbInformation)'確認用
'↑ファイル削除ここまで
Set FSO = CreateObject("Scripting.FileSystemObject")
For i = 0 To UBound(aryDir)
Delete0Dir FSO.GetFolder(aryDir(i))
Next
'==============================================================
' ファイル削除
'==============================================================
Private Sub deleteFiles(baseFolderPath, strExtValue)
Dim arySkippedExt
Dim FSO
Dim dic '拡張子一覧を格納する辞書
Dim index
Dim ext
Dim j
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Set baseFolder = FSO.getFolder(baseFolderPath)
'配列格納
arySkippedExt = Split(strExtValue, ";")
Set dic = CreateObject("Scripting.Dictionary")
'辞書格納
For index = LBound(arySkippedExt) To UBound(arySkippedExt)
ext = arySkippedExt(index)
dic.Add ext, ext
Next
On Error Resume Next
For j=0 To Ubound(arySkippedExt)
For Each tempFile In baseFolder.Files
ext = FSO.GetExtensionName(tempFile)
If Not dic.Exists(ext) Then
'辞書に含まれていない場合
'Wscript.Echo baseFolderPath & ":" & FSO.FolderExists(baseFolderPath)'確認用
FSO.DeleteFile tempFile
End If
Next
For Each tempFolder In baseFolder.SubFolders
Call deleteFiles(tempFolder, strExtValue)
Next
Next
Err.Clear
On Error Goto 0
End Sub
'==============================================================
' 空フォルダ削除
'==============================================================
Sub Delete0Dir(baseFolderPath)
Dim FSO
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
Set baseFolder = FSO.getFolder(baseFolderPath)
For Each Subfolder in baseFolder.SubFolders
On Error Resume Next
'ファイルの属性が8の倍数の場合は削除可能、1046(C:\Users\DPC170\Documents\My Music.lnk等)は削除しない
If Subfolder.Size = 0 AND SubFolder.attributes Mod 8 = 0 Then
FSO.GetFolder(Subfolder.Path).Delete
Else
Exit Sub
Err.Clear
On Error GoTo 0
End If
Next
For Each subfolder2 in baseFolderPath.SubFolders
'再帰
Delete0Dir subfolder2
Next
End Sub
'==============================================================
' ファイルコピー
'==============================================================
Sub FileCopy(strCopyFrom, strCopyTo)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
'エラー発生時にも処理を続行するよう設定
On Error Resume Next
'ファイルを上書きコピー
FSO.CopyFolder strCopyFrom, strCopyTo, True
If Err.Number <> 0 Then
'ここにエラー時の処理を記述
WScript.Echo "ファイルコピーエラーです。" & vbCrLf & _
"エラーNo：" & Err.Number & vbCrLf & _
"エラー内容：" & Err.Description
Err.Clear
End If
On Error Goto 0
End Sub
