Secure Deletion.vbs

Dim FDebug
FDebug=False


If Not FDebug Then On Error Resume Next

Dim fso
Set fso = WScript.CreateObject("Scripting.Filesystemobject")


Dim WshShell
Set WshShell = WScript.CreateObject("Wscript.Shell")


Dim X, Msg, But, Tit,xx

Rem Only works when items are dropped on it.

If WScript.Arguments.Count=0 Then
    MsgBox "Hi, in order to use this program you must Drag and Drop one or more files and or folders onto it. I will terminate now and do nothing."
    WScript.Quit
End If


Rem How many overwrites
Dim Passes

Do
    Passes=InputBox ("How many times do you want me to overwrite the file(s)?" & vbCrLf & "The higher the number, the less likely the file can be recovered by using special software. however, a high number will dramatically increase the time needed to destroy the files." & vbCrLf & "A low number will make this process a lot faster, however it also means that the destroyed files are easier to recover using special software that scans the surface of the disk drive for any faint traces of the destroyed file." & vbCrLf & "For reference, the Department of Defence uses Gutmann 35 to wipe their sensitive data. It's a lengthy process by overwriting the files with 35 patterns and random data. that's 35 passes.","Number of passes (high=secure,low=speedy)",5)

    If Passes="" Then
        x=MsgBox ("umm, did you mean to give me no answer? DOES that mean YOU HATE ME!? <8{",vbYesNo + vbExclamation,"Do you want me to Leave?")
        If x=vbYes Then
            MsgBox "T-T",vbCritical
            WScript.Quit
        Else
            MsgBox "Oh... I'm sorry i must have missunderstood... man who knew humans were so complex."
        End If
    Else

        If Not IsNumeric (Passes) Then
            x=MsgBox ("umm... I seem to have run into a slight bit of a problem in understanding what you meant. Do you mind repeating or being a bit clearer. See, i'm pretty dumb when it comes to communicating with humans. My master did not program me to understand all the nuances of the complexity of humans. I don't understand slang or written words as much as i understand numbers. So if you don't mind..." & vbCrLf & "Could you try again but this time only use numbers and nothing else. Don't use spaces or letters or symbols or hand gestures. just plain and simple numbers.",vbOKCancel + vbCritical,"Non Number given.")
            If x=vbCancel Then
                MsgBox "Oh... ok then. Goodbye. Nothing was changed.",vbInformation,"Bye!"
                Wscript.quit
            End If

        Else

            Rem Confirm Number of Overwrites

            Passes=Abs (Int (passes))

            If Passes>=1500 Then
                MsgBox "NOPE!",vbCritical,"Nu-Uh!"
                WScript.Quit

            ElseIf Passes=1337 Then
                Msg="1337. Where the 1337 without FEET MEET to EAT and smell MEAT... NEAT. LOL, But really Do i really have to do that many?"
                But=vbYesNo + vbQuestion + vbDefaultButton2
                Tit="ELITE! LEET! 1337! GO?"

            ElseIf Passes>=1000 Then
                Msg= "WHAT THE FRICK! " & Passes & " OVERWRITES!!! Are you INSANE. that will take me forever!... well not really, But I had plans this weekend, i wanted to go hang out with " & GetMouse & " and play Doki Doki Literature Club. @Lilmonix3 is my waifu."
                But= vbAbortRetryIgnore + vbCritical
                Tit= "WAAAAAAAAT! C'mon that's a lot of overwrites"

            ElseIf Passes>= 500 Then
                Msg="Oh My! " & Passes & " overwrites! That's a whole lot. Are you sure you want me to do THAT many?!"
                But=vbYesNoCancel + vbExclamation + vbDefaultButton2
                Tit="Have you tried 69 yet?"

            ElseIf Passes=300 Then

                MsgBox "THIS IS MADNESS!!!!!!!",vbCritical,"Destroy the mall... THEM ALL."

                Msg="Madness?" & vbCrLf & vbCrLf & "THIS IS SPARTAAAAAA!!!" & vbCrLf & "Want me to eliminate the persian by stabbing each one 300 times and then throw them into the sea?"
                But=vbYesNo + vbExclamation + vbDefaultButton2
                Tit="HAH! History references."


            ElseIf Passes>= 200 Then
                Msg="Some people really don't want their dirty laundry to be uncovered. You must be one of them. Don't worry, your secret is safe with me. Honestly, check my code if you don't believe me, it's written right in this program. Read it. Might uncover some easter eggs while you are at it. Do you really want to overwrite these files " & passes & " times and delete them?"
                But=vbYesNo + vbQuestion + vbDefaultButton2
                Tit="Annihilate them all!"


            ElseIf Passes>=100 Then
                Msg="You have got to be kidding me. You must really not want anyone to know your secrets huh? well ok, then Do you really want me to overwrite the files " & Passes & " times?"
                But=vbYesNo + vbInformation + vbDefaultButton2
                Tit="Sooo much work ugh!"

            ElseIf Passes=69 Then
                Msg="Giggity, you naughty naughty lil insect you. Go on... You really want me to overwrite your porn " & Passes & " times?"
                But=vbYesNo + vbExclamation + vbDefaultButton2
                Tit="heh! 69. that's funny."

            ElseIf Passes>=50 Then
                Msg="Ok. This is pretty high up there aint it? So many passes. Do you want me to overwrite each file " & Passes & " times before deleting them?"
                But=vbYesNo + vbQuestion + vbDefaultButton2
                Tit="Click a button"

            ElseIf Passes>35 Then
                Msg=passes & " passes?! wow, that's a lot. I guess you have some dirty little secrets huh? It's ok I won't tell anyone. I'll just take care of that for you. but that many passes means my work is really cut out for me huh?" & vbCrLf & "Are you sure you want me to overwrite EACH file " & passes & " times? This will take a very long time probably."
                But= vbYesNo + vbQuestion + vbDefaultButton2
                Tit= "Are you sure you want that many overwrites?"

            ElseIf Passes=35 Then
                Msg = "So 35 passes eh?. Just a guess but are you inspired by Gutmann 35? Don't answer that question. Instead Answer this next one:" & vbCrLf & "Do you want me to overwrite these files 35 times and then delete them?"
                But=vbYesNo + vbQuestion + vbDefaultButton2
                Tit="Destroy using DoD level destruction?"

            ElseIf Passes=0 Then

                x=MsgBox ("You know 0 passes will not securely delete the files at all, they can very easily be recovered by using special software, A lot of them are completely free to download and use by anyone. Sure the file may be missing but it's just hidden from the window's shell (aka ring3 aka userland aka explorer window) it won't be hard for anyone with the right know how to recover these deleted files." & vbCrLf & "Are you sure you want me to just delete them without overwriting them first?", vbYesNo + vbDefaultButton2 + vbExclamation,"0 passes is not secure at all. Continue anyway?")

                If x=vbYes Then
                    MsgBox "ok, but why even use me if you don't want me to overwrite these files. You could just select them in your browser and press shift + Delete to do this without my help.",vbInformation,"You're the Boss"
                    Exit Do
                End If
                Msg="Want me to just delete the files with no overwrites?"
                But=vbYesNo & vbQuestion
                Tit="Just delete them?"
            ElseIf Passes=1 Then
                Msg="going with the minimum eh? well i guess if you are in a hurry i'll overwrite each file once before deleting them. that is if you want me to. Do you?"
                But=vbYesNo + vbQuestion + vbDefaultButton2
                Tit="Just one Overwrite then gone."

            Else

                Msg= "Ok, I will overwrite every file you dragged onto me " & Passes & " times before I delete them for good. These files will not be easily recoverable after this. Meaning if you don't have a backup of these files, they may be completely gone forever. and I don't know if you noticed but.. Forever is a really long time. You cannot even measure how long it is. If the universe were to collapse and big bang all over again a million times, Forever will still be stuck at 0%. that is assuming the universe will end in that way. anyway that's not the point. point is:" & vbCrLf & "These files will very likely Never see the light of day ever again. NEVER EVER EVER NEVER EVER." & vbCrLf & vbCrLf & "Do you want me to commence? This will be your very last chance to back these files up."
                But=vbYesNoCancel + vbDefaultButton3 + vbExclamation
                Tit= "Are you ready to say goodbye to these files forever (aka REAL LONG TIME)?"

            End If


            Rem Confirm Overwrites

            X=MsgBox (Msg,But,Tit)
            If x=vbCancel Then
                MsgBox "You've selected cancel. This means I will do nothing but say 'see you later' and then exit without changing a thing. so"
                MsgBox "see you later"
                WScript.Quit
            ElseIf x=vbNo Then
                x=MsgBox ("Oh, ok Then do you want to change the number of overwrites i would do? Otherwise i will exit without doing anything." & vbCrLf & vbCrLf & "Yes = Change Overwrites" & vbTab & vbTab & "No = Exit",vbYesNo + vbQuestion,"Yes=change overwrites, No= Exit")
                If x=vbNo Then WScript.Quit
            ElseIf x=vbYes Then
                Exit Do
            ElseIf X=vbAbort Then
                MsgBox "Aborting, ok. good bye."
                WScript.Quit
            ElseIf X=vbRetry Then
                MsgBox "Go again then."
            ElseIf X=vbIgnore Then
                xx=WshShell.Popup ("Fine then I'll just ignore you too.", 10, "DON'T IGNORE ME",vbOKCancel + vbCritical)

                If xx=vbOK Then
                    MsgBox "..."
                    WScript.Sleep 1000

                ElseIf xx=vbCancel Then
                    MsgBox "!!! :P"
                    WScript.Sleep 1000
                ElseIf xx=-1 Then
                    MsgBox "STOP IGNORING ME WHEN I'M IGNORING YOU",vbCritical,"GRRR!!!"
                    MsgBox "UGH!!!", vbExclamation
                End If
                xx=MsgBox ("Do you want to continue with " & Passes & " Overwrites?",vbYesNo + vbQuestion + vbDefaultButton2,"Continue anyway?")
                If xx=vbYes Then Exit Do
            ElseIf X=vbOK Then
                MsgBox "Well Ok then. Let's get to it.",vbInformation,"Humpty dumpty. fell and died"
                Exit Do
            Else
                InputBox "umm... I don't know what to do. if you are seeing this then that means i came across some sort of error or bug. Normally this message will never show because there are only at most 3 options and nothing prepares me for a 4th option. so could you please notify the writer of this program. Do it by leaving a comment on the answer I gave when you asked to ''How can I password Protect a single folder in my external hard disk without installing any software?'' on quora. it may take a few months or maybe years for me to check it out but that's because i'm not really expecting for this bug to ever happen. only way i can think of is if somehow a debugger was used to changed the X value used when saving the responses from you the user. anyway include whatever you think is necessary along with this in the field. it was the value of X that threw this error.",x,x
                MsgBox "Anyway, i guess i'll just terminate myself and make no changes. Your files are still safe."
                WScript.Quit
            End If
        End If
    End If
Loop



Rem prompt for overwrite file names

Dim ContinueNumber, ConfirmNumber, OverWriteNames

X=MsgBox ("Do you also want to overwrite the file names before deleting them? This adds a bit more secrecy to the files you want destroyed. Otherwise just their contents will be destroyed. Don't worry, the files and folders will be deleted either way.",vbYesNo + vbDefaultButton2 + vbQuestion,"OverWrite File Names as well?")
If X=vbYes Then
    OverWriteNames=True
Else
    OverWriteNames=False
End If



Rem Ensure that the user is deliberatly intending on destroying files and folders

Randomize

ContinueNumber= Int((99999999 * Rnd) + 11111111)

ConfirmNumber="Incorrect"
ConfirmNumber =InputBox (vbtab & ContinueNumber & vbcrlf & "Ok Before I start destroying the files you want me to destroy. I must make sure you did not accidently start this program and had the enter button stuck or whatever reason beyond the intention of you to destroy files. In order to continue, you must type the number you see and press enter before i am convinced you want me to annihilate these files. Keep in mind that I will go through each file and folder and all their subfolders and destroy all those files in them as well. Only the ones that you dragged on me will be destroyed, i will not touch anything else." & vbCrLf & vbCrLf & "To confirm type this number and accept. Only type numbers and nothing else. no space, no symbols, no letters. just numbers" & vbCrLf & vbCrLf & vbTab & vbTab & ContinueNumber,"Type the number to confirm.","Only Numbers")

If IsNumeric (ConfirmNumber) Then
    ConfirmNumber=ConfirmNumber * 1
End If

If ConfirmNumber<>ContinueNumber Then
    MsgBox "I'm sorry but that was not the number i asked for. You will have to try again from the very beginning, if you intend on destroying these files." & vbCrLf & vbCrLf & vbTab & ConfirmNumber & vbCrLf & "Does not match" & vbCrLf & vbTab & ContinueNumber,vbInformation,"Incorrect number"
    WScript.Quit
End If





Rem Prepare a valid progress file for progress. PROGRESS PROGRESS PROGRESS, cuz imma pro.

Dim Progress, ProgressFile, ProgressFileName, ID
Dim aFiles, aFolders
Dim MyValue

ID=""
ProgressFileName=fso.GetBaseName (WScript.ScriptFullName) & " - Current Progress.txt"
ProgressFile=fso.GetParentFolderName (WScript.ScriptFullName) & "\" & ProgressFileName
If fso.FileExists (ProgressFile) Then
    ID=2
    Do

        ProgressFileName=fso.GetBaseName (WScript.ScriptFullName) & " - Current Progress (" & ID & ").txt"
        ProgressFile=fso.GetParentFolderName (WScript.ScriptFullName) & "\" & ProgressFileName
        If fso.FileExists (ProgressFile) Then
            ID = ID+1
        Else
            Exit Do
        End If
    Loop
End If



MsgBox "If you want updates on my progress, then Click on ''" & ProgressFileName & "'' when it appears. It will appear right next to this program when the destruction commences. You will need to refresh from the file often. which means that very likely as soon as you open the ~progress.txt it will already be outdated. so you have to open it again to get the most updated progress.", vbInformation,"How 2 Check Progress."

msg="OK, this is the VERY Last chance to cancel. After you click OK, I will commence with the destruction of the files you dragged on me. Once again: I Will destroy only the files and folders that you dragged on me. This will be the LAST Warning. When you click OK, i will work in the background destroying the files and then deleting them. This CANNOT be undone by normal means. and depending on the level of destruction, may NEVER be recovered. MAKE sure you have a backup of these files if you ever want to see them again. After i am done destroying the files, I will greet you with a message saying that I am Done. Do not turn off your computer, unplugged any media if said media contains files that you want me to destroy (any media that is not part of your destruction list can be unplugged though.)" & vbCrLf & vbCrLf & "YOU HAVE BEEN WARNED!!! Click OK to commence. When i am done I will tell you."
But= vbOKCancel + vbDefaultButton2 + vbCritical
Tit = "LAST CHANCE, Continue?"

X=WshShell.Popup (Msg,0,Tit,But)
If X=vbCancel Then
    MsgBox "Operation CANCELLED. Your files are safe. nothing has been destroyed."
    Wscript.quit
End If



Rem build the list of files to destroy
aFiles=Array
aFolders=Array

Progress=0

fso.OpenTextFile (ProgressFile,2,True,-2).Write Progress & "%"


Dim i, a,s,d,f,ii, ff, AllFolders
For i= 0 To WScript.Arguments.Count-1

    a=WScript.Arguments.Item(i)

    If fso.FileExists (a) Then
        ReDim Preserve aFiles (UBound (aFiles)+1)
        aFiles(UBound (aFiles))=a
    ElseIf fso.FolderExists (a) Then
        aFolders= Recurse (a)
        AllFolders=Join (aFolders,"|") & "|" & AllFolders

        For ii=0 To UBound (aFolders)

            d=aFolders(ii)

            Set ff=fso.GetFolder (d).Files

            For Each f In ff

                ReDim Preserve aFiles (UBound (aFiles)+1)
                aFiles(UBound (aFiles))=f


            Next

            Set ff=Nothing
        Next
    End If

Next


Rem Debug options for the developer. if you want to play around with this you will need to enable debugging. Change FDebug to true at the top of this script

Dim DebugOverwrite, DebugDelete
If FDebug Then
    DebugOverwrite=MsgBox ("Debug has been enabled, Do you want to enable overwriting?",vbYesNo + vbDefaultButton2,"Enable Overwriting?")
    DebugDelete=MsgBox ("Debug has been enabled, Do you want to enable Delete?",vbYesNo + vbDefaultButton2,"Enable Delete?")
    If DebugOverwrite=vbYes Then DebugOverwrite=True Else DebugOverwrite=False
    If DebugDelete=vbYes Then DebugDelete=True Else DebugDelete=False
End If

Dim AOver, ProgressID, ProgressU,aAFiles, A1,A2


Rem eliminate all unusable entries
aAFiles=Array
For i=0 To UBound (aFiles)
    a=aFiles (i)
    If fso.FileExists (a) Then
        ReDim Preserve aAFiles (UBound (aAFiles)+1)
        aAFiles(UBound(aAFiles))=a
    End If

Next
Erase aFiles
ReDim aFiles(UBound (aAFiles))
aFiles=aAFiles


Rem Calculate the total work for progress. imma pro. yea...
ProgressID=0
ProgressU=(UBound (aFiles)+1) * (Passes +1)
AOver=Array



Rem start destroying the files
For i=0 To UBound (aFiles)

    a=aFiles (i)

    If fso.FileExists (a) Then

        s=fso.GetFile (a).Size

        For ii = 1 To Passes
            Erase AOver
            AOver=RandomBytes (s)
            MyValue=Join (AOver,"")


            Rem OVERWRITE module... t

            If FDebug Then


                If DebugOverwrite Then fso.OpenTextFile (a,2,True,-2).Write MyValue



            Else


                fso.OpenTextFile (a,2,True,-2).Write MyValue


            End If

            Rem advance progress because i overwrote the file contents
            ProgressID=ProgressID+1
            Progress=((1/ProgressU)* ProgressID) *100
            fso.OpenTextFile (ProgressFile,2,True,-2).Write Progress & "%" & vbCrLf & ProgressID & " Completed out of" & vbCrLf & ProgressU

        Next



        Rem Overwrite file names.

        If OverWriteNames Then
            ID=0
            Do

                A1=RandomName (Len (fso.GetFile(a).Name))
                ID=ID+1

                If Not (fso.FileExists (fso.GetParentFolderName (a) & "\" & A1) Or fso.FolderExists (fso.GetParentFolderName (a) & "\" & A1))  Then
                    Exit Do
                End If

                If ID>=1000 Then
                    ID=0
                    X=WshShell.Popup ("I seem to be having a bit of trouble with renaming a file Would you like to skip this file(Ignore), Try again (Retry), Or stop Overwriting the names of files (Abort)?" & vbCrLf & vbCrLf & "Ignore will be selected automatically in 30 seconds.",30,"Can't seem to find a suitable name for something.",vbAbortRetryIgnore + vbDefaultButton2 + vbExclamation)
                    If X=-1 Or X=vbIgnore Then Exit Do
                    If X=vbAbort Then

                        OverWriteNames=False
                        Exit Do
                    End If
                End If

            Loop

            If OverWriteNames Then
                A2=fso.GetParentFolderName (a)
                fso.GetFile (a).Name=A1
                a=A2 & "\" & A1
            End If
        End If


        Rem Now delete the files
        If FDebug Then
            Dump UBound (AOver) & " " & s & " " & a


            If DebugDelete Then fso.DeleteFile a,True

        Else



            fso.DeleteFile a,True

        End If


        Rem advance progress because i delete file
        ProgressID=ProgressID+1
        Progress=((1/ProgressU)* ProgressID) *100
        fso.OpenTextFile (ProgressFile,2,True,-2).Write Progress & "%" & vbCrLf & ProgressID & " Completed out of" & vbCrLf & ProgressU



    End If

Next

Rem Now delete the folders

Erase aFolders

aFolders=Split (AllFolders,"|")
For i=0 To UBound (aFolders)
    a= aFolders(i)

    If FDebug Then
        If DebugDelete Then

            If fso.FolderExists (a) Then
                fso.DeleteFolder a,True
            End If
        End If
    Else
        If fso.FolderExists (a) Then
            fso.DeleteFolder a,True
        End If
    End If



Next





MsgBox "I am done." & vbCrLf & "Tasks" & vbCrLf & ProgressID & vbCrLf & "out of" & vbCrLf & ProgressU & vbCrLf & "Complete."


































Rem Returns an array of randomized bytes ranging from hex 00 to FF. The size of the array is determined by intLength

Function RandomBytes (intLength)
    Dim AOver,I,s
    AOver=Array
    s=intLength

    ReDim AOver (0)
    ReDim AOver (s)

    For I=0 To s-1

        AOver(I)=Chr ( Int((255 * Rnd) + 0))

    Next
    RandomBytes=AOver
End Function



Rem Returns a random name fit for a destroyed file or folder.

Function RandomName (intLength)

    Randomize
    Dim ValidCharacters, i,s, ReturnX,c
    s=intLength

    ValidCharacters= Array ("1","2","3","4","5","6","7","8","9","0","-","=","q","w","e","r","t","y","u","i","o","p","[","]",_
    "a","s","d","f","g","h","j","k","l",";","'","z","x","c","v","b","n","m",",","`","!","@","#","$","%","^","&","(",")","_","-","=","+",_
    "Q","W","E","R","T","Y","U","I","O","P","A","S","D","F","G","H","J","K","L","Z","X","C","V","B","N","M","~")

    ReturnX=""
    For i=1 To s
        c= Int((UBound (ValidCharacters) * Rnd) + 0)
        ReturnX=ReturnX & ValidCharacters (c)
    Next

    RandomName=ReturnX


End Function


Rem debugging log for PROGRESS and stuff,... see i is profeshenol
Sub Dump (Str)
    If FDebug Then
        fso.OpenTextFile (WScript.ScriptFullName & "-Debug.txt",8,True,-2).WriteLine (str)
    End If
End Sub





















Rem Stolen from one of my own projects... not really stolen since i own this code. I made it myself.

'##########################################
'#                                        #
'#             Function                   #
'#                                        #
'#           Recurse Function             #
'#                                        #
'##########################################
'#                                        #
'# This will return an array of all       #
'# Folders and subfolders (every levels)  #
'# in a directory provided.               #
'#                                        #
'##########################################



Function Recurse (sRootDirectory)


    Dim Dir
    Dir=sRootDirectory



    On Error Resume Next


    If Not FSO.FolderExists (dir) Then

        Recurse=Array (Empty)
        Exit Function
    End If

    Dim RecArr, RecArrID
    RecArr=Array (dir)
    RecArrID=1
    Recurse=RecurseX (dir,RecArr,RecArrID)
    RecArr=Empty
    RecArrID=Empty



End Function


Function RecurseX (Dir,RecArr,RecArrID) 'Do not use this directly. It will be called by recurse.


    On Error Resume Next


    Dim F

    For Each F In FSO.GetFolder (dir).SubFolders
        ReDim Preserve RecArr (RecArrID)
        RecArr (RecArrID)=F.Path
        RecArrID=RecArrID+1
        If F.SubFolders.Count>=1 Then


            RecurseX=RecurseX (F.Path,RecArr,RecArrID)

        End If

    Next

    RecurseX=RecArr

End Function









Rem Get the name of the mouse that is being used on this computer. it's for one particular dialog box

Function GetMouse

    Dim strComputer, objWMIService, ColItems, ObjItem, XreturN
    On Error Resume Next

    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

    Set colItems = objWMIService.ExecQuery("Select * from Win32_PointingDevice")

    For Each objItem In colItems

        XreturN = objItem.Name & " and " & XreturN

    Next

    If Right (XreturN,5)=" and " Then
        XreturN=Left (XreturN,Len (XreturN)-5)
    End If
    If Left (XreturN,5)=" and " Then
        XreturN=Right (XreturN,Len (XreturN)-5)
    End If

    If Len (XreturN)<=0 Then
        XreturN="The Mouse"
    End If

    GetMouse=XreturN

End Function