by Vasudev D.Sharma (2 Submissions)
Category: Encryption
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 28th August 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
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