VBScriptでフォルダ配下のファイルのみを全削除する(フォルダ構造は維持)

VBScriptを使い、指定したフォルダおよびそのサブフォルダの中の.txtファイルをすべて削除するプログラムを紹介します。指定したフォルダのサブフォルダ、そのまたサブフォルダ……というフォルダ構造は削除せず維持します。

このプログラムを実行するには、テキストファイルに下記のソースを貼り付け、拡張子「.vbs」で保存し、保存したファイルをダブルクリックしてください。フォルダ選択画面が表示され、フォルダを選択すると実行可否を尋ねるダイアログが表示されます。非常に危険なので、ダイアログのボタンの既定値は「いいえ」にしてあります。

「はい」をクリックすると、指定したフォルダ、そのすべてのサブフォルダ、そのすべてのサブフォルダ……の中の.txtファイルがすべて削除され、終了後にメッセージ「ファイル削除が完了しました」が表示されます。このメッセージは、削除対象のファイルが全くない場合など、削除を実施していない時にも表示されます。

本ブログラムの実行結果に作者は責任を持ちません。大事なファイルがあるフォルダは絶対に指定しないでください。対象ファイルが読み取り専用属性の場合など、ファイルを削除できない場合もあります。また、大量のサブフォルダやファイルがあるフォルダを指定すると、PCがフリーズする可能性があります。


Option Explicit
Private Const TARGET_EXTENTION = "txt"
Call main

Sub main()
    Dim baseFolderPath
    
    baseFolderPath = selectForder
    If baseFolderPath = "" Then
        Exit Sub
    End If
    
    If MsgBox("下記のフォルダの配下、サブフォルダの配下にある「" _
            & TARGET_EXTENTION & "」ファイルをすべて削除します。" _
            & "ごみ箱への移動ではなく削除です。" _
            & vbCrLf & "本当によろしいですか? " _
            & "(この操作は取り消しできません)" _
            & vbCrLf & vbCrLf & baseFolderPath _
            , vbYesNo + vbCritical + vbDefaultButton2) = vbNo Then
        Exit Sub
    End If
    
    Call deleteFiles(baseFolderPath)
    
    Call MsgBox("ファイル削除が完了しました。", vbInformation)
End Sub

Private Function selectForder()
    Dim objShell
    Dim objFolder
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "配下の「" _
            & TARGET_EXTENTION & _
            "」ファイルを削除したいフォルダを選択してください。", 0)
    
    selectForder = ""
    If Not objFolder Is Nothing Then
        selectForder = objFolder.Items.Item.Path
    End If
    
    Set objShell = Nothing
    Set objFolder = Nothing
End Function

Private Sub deleteFiles(baseFolderPath)
    Dim FSO
    Dim baseFolder
    Dim tempFile
    Dim tempFolder
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set baseFolder = FSO.getFolder(baseFolderPath)
    
    For Each tempFile In baseFolder.Files
        If FSO.GetExtensionName(tempFile.Name) = TARGET_EXTENTION Then
            On Error Resume Next
            tempFile.Delete
            On Error GoTo 0
        End If
    Next
    
    For Each tempFolder In baseFolder.SubFolders
        Call deleteFiles(tempFolder)
    Next
    
    Set FSO = Nothing
    Set tempFile = Nothing
    Set tempFolder = Nothing
End Sub

このプログラムは、「call main」を削除すると、そのままExcel VBAに貼り付けられます。
また、 「TARGET_EXTENTION = "txt"」の「"txt"」を好きな拡張子に変えることで削除対象の拡張子を変更できます。

COMMENTS

名前

Android,6,Canon,2,EF24-105 F4L IS USM,1,Eos 70d,4,EOS Kiss X7,4,Excel,4,GIMP,5,Git,3,Git Bash,3,Inkscape,3,iPhone,1,Kindle,2,Lightroom,1,Office,2,PC,7,PDF,1,SSH,3,ThinkPad,11,ThinkPad R61e,2,ThinkPad X240,4,ThinkPad X260,6,TOEFL,1,TOEIC,4,VBA,6,VBScript,3,VMware player,1,WEB制作,3,Windows,5,Windows 10,2,インターネットバンキング,1,カメラ,8,パソコン周辺機器,1,パソコン部品,2,レビュー,1,レンズ,2,圧縮&解凍,3,英語,7,仮想環境,1,撮影機材,6,雑感,2,子育て,3,資格,13,情報処理技術者試験,5,中古,4,電子書籍,2,動画,2,簿記,2,
ltr
item
勉強とガジェット: VBScriptでフォルダ配下のファイルのみを全削除する(フォルダ構造は維持)
VBScriptでフォルダ配下のファイルのみを全削除する(フォルダ構造は維持)
https://2.bp.blogspot.com/-XPJO8b0UBj4/WENQ_lNnj8I/AAAAAAABwNQ/n9iQhFHnNaQ5FsBHXOS4IXKJN7jFUU-cgCLcB/s400/garbage-can-1111448_1920.jpg
https://2.bp.blogspot.com/-XPJO8b0UBj4/WENQ_lNnj8I/AAAAAAABwNQ/n9iQhFHnNaQ5FsBHXOS4IXKJN7jFUU-cgCLcB/s72-c/garbage-can-1111448_1920.jpg
勉強とガジェット
http://tanaka-misaki.blogspot.com/2011/12/vbscript.html
http://tanaka-misaki.blogspot.com/
http://tanaka-misaki.blogspot.com/
http://tanaka-misaki.blogspot.com/2011/12/vbscript.html
true
8692194293250221214
UTF-8
Loaded All Posts Not found any posts VIEW ALL Readmore Reply Cancel reply Delete By Home PAGES POSTS View All RECOMMENDED FOR YOU LABEL ARCHIVE SEARCH ALL POSTS Not found any post match with your request Back Home Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sun Mon Tue Wed Thu Fri Sat January February March April May June July August September October November December Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec just now 1 minute ago $$1$$ minutes ago 1 hour ago $$1$$ hours ago Yesterday $$1$$ days ago $$1$$ weeks ago more than 5 weeks ago Followers Follow THIS CONTENT IS PREMIUM Please share to unlock Copy All Code Select All Code All codes were copied to your clipboard Can not copy the codes / texts, please press [CTRL]+[C] (or CMD+C with Mac) to copy