2022年2月06日: Cygwin shred.exe でファイルを復元不能に消す VBScript ユーティリティ

2022-02-06: Cygwin shred.exe でファイルを復元不能に消す VBScript ユーティリティ

2022年02月06日 18時11分

復元できないようにファイルを削除する Cygwin のコマンド shred.exe を Windows で手軽に使うための VBScript。これを ～.vbs てゆうファイルで作成して、消したいファイルとかフォルダとか単数でも複数でもいいからそのアイコンにドラッグすればいいの。

Option Explicit

' =============================================================================
Const AppName = "シュレッダー"

Dim fso: Set fso = CreateObject ("Scripting.FileSystemObject")
Dim shell: Set shell = CreateObject ("WScript.Shell")

' =============================================================================

Function MakeTempNameIn (parentFolder)
  Do
    Dim tempName: tempName = fso.GetTempName
    Dim tempPath: tempPath = parentFolder.Path & "\" & tempName
  Loop While _
    fso.FileExists (tempPath) Or fso.FolderExists (tempPath)
  MakeTempNameIn = tempName
End Function

' =============================================================================

Sub RenameFile (file, targetFiles)
  file.Name = MakeTempNameIn (file.ParentFolder)
  Set targetFiles(UBound(targetFiles)) = file
  ReDim Preserve targetFiles(UBound(targetFiles)+1)
End Sub

' =============================================================================

Sub RenameFolder (folder, targetFiles, targetFolders)
  folder.Name = MakeTempNameIn (folder.ParentFolder)
  Set targetFolders(UBound(targetFolders)) = folder
  ReDim Preserve targetFolders(UBound(targetFolders)+1)

  Dim file
  For Each file In folder.Files
    RenameFile file, targetFiles
  Next

  Dim subFolder
  For Each subFolder In folder.SubFolders
    RenameFolder subFolder, targetFiles, targetFolders
  Next
End Sub

' =============================================================================

Sub ShredFiles (files)
  Dim files_uBound: files_uBound = UBound(files)
  Dim fi: fi = 0
  Do
    Dim command: command = "C:\cygwin64\bin\shred.exe"
    Do While fi<=files_uBound
      Dim arg: arg = " """ & files(fi).Path & """"

      ' 8191 ... https://learn.microsoft.com/ja-jp/troubleshoot/windows-client/shell-experience/command-line-string-limitation
      If Not Len(command)+Len(arg) <= 8191 Then
        Exit Do
      End If

      command = command & arg

      fi = fi + 1
    Loop
    shell.Run command, 7, True
  Loop While fi<=files_uBound
End Sub

' =============================================================================

Sub Main
  If 0 < WScript.Arguments.Count Then
    If vbYes <> MsgBox (WScript.Arguments.Count & "個のファイルを削除しようとしています。続けますか。", vbYesNo, AppName) Then
      Exit Sub
    End If
  End If

  Dim path

  Dim i
  For i = 0 To WScript.Arguments.Count-1
    path = WScript.Arguments(i)
    If fso.FolderExists (path) Then
      If vbYes <> MsgBox ("フォルダを削除しようとしています。続けますか。", vbYesNo, AppName) Then
        Exit Sub
      Else
        Exit For
      End If
    End If
  Next

  Dim targetFiles(): ReDim targetFiles(0)
  Dim targetFolders(): ReDim targetFolders(0)

  For i = 0 To WScript.Arguments.Count-1
    path = WScript.Arguments(i)
    If fso.FileExists (path) Then
      RenameFile fso.GetFile (path), targetFiles
    ElseIf fso.FolderExists (path) Then
      RenameFolder fso.GetFolder (path), targetFiles, targetFolders
    End If
  Next

  If 0 < UBound(targetFiles) Then
    ReDim Preserve targetFiles(UBound(targetFiles)-1)

    ShredFiles targetFiles
  
    Dim file
    For Each file In targetFiles
      file.Delete
    Next
  End If

  If 0 < UBound(targetFolders) Then
    ReDim Preserve targetFolders(UBound(targetFolders)-1)

    For i = UBound(targetFolders) To 0 Step -1
      targetFolders(i).Delete
    Next
  End If
End Sub

Main

' =============================================================================
' [EOF]