FSO 指定フォルダ指定ファイル削除・このサンプルでは[Thumbs.db]を削除しています。
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub 指定フォルダ指定ファイル削除() '*********************************** '指定フォルダ指定ファイル削除 '*********************************** '指定フォルダ内のファルダを含むフォルダ内の特定ファイルを削除する '指定フォルダを含む2階層まで検索 'このサンプルでは[Thumbs.db]を削除しています。 Dim strFilePath As String Dim objFSO As Object Dim strOpenPath As String Dim objFolder As Object Dim objSubFolder As Object Dim objFile As Object Dim strFileName As String Dim GetFileName As String Dim lngCnt As Long GetFileName = "Thumbs" '検索するファイル名 lngCnt = 0 strOpenPath = ThisWorkbook.Path Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.GetFolder(strOpenPath) 'フォルダ直下 For Each objFile In objFolder.Files strFilePath = objFile.Path strFileName = objFSO.GetFileName(strFilePath) If InStr(1, strFileName, GetFileName) <> 0 Then If MsgBox(strFilePath & vbNewLine & "Delete?", vbOKCancel, strFileName) = vbOK Then lngCnt = lngCnt + 1 '[Kill]関数では"Thumbs.db"等の特殊ファイルは削除不可 objFSO.GetFile(strFilePath).Delete End If End If Next 'サブフォルダ For Each objSubFolder In objFolder.SubFolders For Each objFile In objSubFolder.Files strFilePath = objFile.Path strFileName = objFSO.GetFileName(strFilePath) If InStr(1, strFileName, GetFileName) <> 0 Then If MsgBox(strFilePath & vbNewLine & "Delete?", vbOKCancel, strFileName) = vbOK Then lngCnt = lngCnt + 1 '[Kill]関数では"Thumbs.db"等の特殊ファイルは削除不可 objFSO.GetFile(strFilePath).Delete End If End If Next Next Set objFSO = Nothing MsgBox "処理終了" & vbNewLine & lngCnt & " 個のファイルを削除しました。", 0, "処理終了" End Sub |