• Home
 · 
• Encryption
 · 
• Encrypts every file in a directory

Encrypts every file in a directory

Encrypts every file in a directory

API Declarations


' an error I debugged it
' Bug found on August 16, 2002

' Bug Description: when the directory contains only one file it goes in for
' encrypting the same file twice which results in the Encryption+Decryption
' hence no Output
' the place where the bug was there has been marked with <--
' bug found by Vasudev D.Sharma, [email protected]

' Description:
' Originally written in Excel 97,
' This program encrypts each and every contents of the directory
' even File name

'Declarations:
'None





Rate Encrypts every file in a directory

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

    Dim mybit As String * 1

    strPwd = ""
    mybit = String(1, " ")
    strPwda = ""
    tmp1 = ""
    tmp2 = ""
    tmp3 = ""
    tmp4 = ""
    newfile = ""

    'get directory
    files = Application.GetOpenFilename(Title:="Select any file within target directory ")
    If files = False Then Exit Sub
    myfile = files
          
    'seperate file name
    Do
        pos = InStr(myfile, "\")
        myfile = Right$(myfile, Len(myfile) - pos)
        
    Loop Until pos = 0
    
    'get only directory name by removing string of the length of file name
    'from the right
    mypath = Left$(files, Len(files) - Len(myfile))
                
    'Get password
    strPwda = InputBox("Password to Encrypt or Decrypt")

    tmp1 = UCase(strPwda)
    tmp2 = LCase(strPwda)

    For z = 1 To Len(strPwda)
        If z Mod 2 = 0 Then
            k = UCase(Mid(strPwda, z, 1))
            j = LCase(Mid(strPwda, z, 1))
        Else
            k = LCase(Mid(strPwda, z, 1))
            j = UCase(Mid(strPwda, z, 1))
        End If
        tmp3 = tmp3 & k
        tmp4 = tmp4 & j
    Next z

    strPwda = tmp1 & tmp3 & tmp2 & tmp4

    'encode the password
    For i = 1 To Len(strPwda)
        strPwd = strPwd & Chr(Asc(Mid(strPwda, i, 1)) Xor Asc(Mid(strPwda, (i Mod Len(strPwda)) + 1, 1)) And &HFF)
    Next i
        
    
    ' Count number of files present in the directory
    filecount = 0
    
    myfile = Dir(mypath & "*.*")    ' Get files from the directory
    Do
        filecount = filecount + 1
        myfile = Dir                ' Seperate individual files for counting
    
    Loop Until myfile = ""
    
    '<-----------
    'Temporarily end the program here so that it dosnt goes in for real encryption
    'Exit Sub
    '----------->



    '****************************************************************
    '               Go in for the real encryption
    
    myfile = Dir(mypath & "*.*")
    sofar = 1
    
    'Do <-- bug was caused by the Do-Until loop which I have replaced with Do-While loop

    While (sofar <= filecount)

        ' Encrypt the name of the directory
    
        For i = 1 To Len(myfile)
            c = Chr(Asc(Mid(myfile, i, 1)) Xor Asc(Left(strPwd, 1)) + 128)
            newfile = newfile & c
        Next i

        filelength = FileLen(mypath & myfile)

        ' Encrypt the contents of the file
        
        Open mypath & myfile For Binary As #1
        For i = 1 To filelength
            Get #1, i, mybit
            mybit = Chr(Asc(mybit) Xor Asc(Mid(strPwd, (i Mod Len(strPwd)) + 1, 1)) And &HFF)
            Put #1, i, mybit
            Application.Caption = Format((i / (filelength / 100)), "0.00") & "%" & "Done - " & sofar & " of " & filecount
        Next i
        Close #1

        old_name = mypath & myfile
        new_name = mypath & newfile
        
        ' rename old file name to the new encrypted one
        
        Name old_name As new_name

        newfile = ""
        myfile = Dir
        sofar = sofar + 1
    Wend
    
    'Loop Until myfile = ""     <-- till here
    
    
    '                           End the encryption
    '*************************************************************************

    Application.Caption = ""

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call encrypt_directory
    
End Sub