Encrypting Directories

Does anyone know how to encrypt directories? A bit of code would be nice. d>:D

'how about encrypting the files in the directory
'using a loop
'

Code:

---


'Encrypt/Unencrypt a file
'
Option Explicit
'
Private Function EncryptFile(sFile As String, iKey As Integer)

    Dim iFake#
    Dim x As String * 1
   
    Dim lP As Long, z
    Dim intNum#
    intNum = FreeFile

    iFake = Rnd(-1)
    Randomize (iKey)
   
   
    lP = 1
    Open sFile For Binary As intNum
   
    While lP <= LOF(intNum)
   
    Get #intNum, lP, x
   
    z = Asc(x) + Int(Rnd * 256)
    If z > 255 Then z = z - 256
   
    x = Chr(z)
   
    Put #intNum, lP, x
   
    lP = lP + 1
   
   
    Wend
   
    Close #intNum

    MsgBox "Your file has been encrypted."

End Function


Private Function DecryptFile(sFile As String, iKey As Integer)

    Dim iFake As Integer
    Dim x As String * 1
   
    Dim lP As Long, z
    Dim intNum#
   
    intNum = FreeFile
 
    iFake = Rnd(-1)
    Randomize (iKey)
   
   
    lP = 1
    Open sFile For Binary As #intNum
   
    While lP <= LOF(intNum)
   
    Get #intNum, lP, x
   
    z = Asc(x) - Int(Rnd * 256)
    If z < 0 Then z = z + 256
   
    x = Chr(z)
   
    Put #intNum, lP, x
   
    lP = lP + 1
   
    Wend
   
    Close #intNum
   
    MsgBox "Your file has been unencrypted."
   
End Function

' <<<<  Form Event Code    >>>>


Private Sub Command1_Click()

    Call EncryptFile("a:\book1.xls", 44)

End Sub

Private Sub Command2_Click()

    Call DecryptFile("a:\book1.xls", 44)

End Sub

---

Using HeSaidJoe's example, you can encrypt all files in a directory. That is, if his code does encrypt any file.

Code:

---

On Error Resume Next
For i = 0 to Dir1.ListCount - 1
Call EncryptFile(Dir1, 44)
Dir1.ListIndex = Dir1.ListIndex + 1
Next i
Msgbox "Encryption of All Files - Complete!", 64

---

Here is what I am currently using:

On Sub Encrypt()
Dim sHead As String
Dim NewFile1
Dim sT As String
Dim sA As String
Dim cphX As New Cipher
Dim n As Long
Dim LenOfFile As Long
Dim TenPercent As Long
Dim OverwriteEncryptedFile As Long

On Error GoTo EncryptError
Open txtFile.Text For Binary As #1
'Load entire file into sA
sA = Space$(LOF(1))
Get #1, , sA
Close #1
'Prepare header string with salt characters
sT = Hash(Date & Str(Timer))
sHead = "---OMITTED---(So you can't crack my encrypted files. :) )" & sT & Hash(sT & txtPassword1.Text)
'Do the encryption
cphX.KeyString = sHead
cphX.Text = sA
cphX.DoXor
cphX.Stretch
sA = cphX.Text

'Write header
' See if we should be shown at startup
OverwriteEncryptedFile = GetSetting(App.EXEName, "Options", "Overwrite Existing File When Encrypting")
If OverwriteEncryptedFile = 0 Then
NewFile1 = txtFile.Text + ".enc"
FileCopy txtFile.Text, NewFile1
txtFile.Text = txtFile.Text + ".enc"
Open NewFile1 For Output As #1
Print #1, sHead
'Write encrypted data

n = 1
Do
Print #1, Mid(sA, n, 70)
n = n + 70
Loop Until n > Len(sA)
Close #1
Exit Sub
End If

OverwriteEncryptedFile = GetSetting(App.EXEName, "Options", "Overwrite Existing File When Encrypting")
If OverwriteEncryptedFile = 1 Then
Kill txtFile.Text
Open txtFile.Text For Output As #1
Print #1, sHead
'Write encrypted data

n = 1
Do
Print #1, Mid(sA, n, 70)
n = n + 70
Loop Until n > Len(sA)
Close #1
Exit Sub
End If






'NewFile1 = txtFile.Text + ".enc"
'FileCopy txtFile.Text, NewFile1
'Open NewFile1 For Output As #1
'Print #1, sHead

'Write encrypted data

'n = 1
' Do
' Print #1, Mid(sA, n, 70)
' n = n + 70
'Loop Until n > Len(sA)
' Close #1

Exit Sub
EncryptError:
MsgBox "Please specity a valid file."
End Sub

Sub Decrypt()
Dim sHead As String
Dim NewFile1
Dim sA As String
Dim sT As String
Dim cphX As New Cipher
Dim n As Long
'Get header (first 18 bytes of encrypted file)
On Error GoTo EncryptError123456
Open txtFile.Text For Input As #1
Line Input #1, sHead
Close #1
'Check for correct password
sT = Mid(sHead, 9, 8)
If InStr(sHead, Hash(sT & txtPassword1.Text)) <> 17 Then
MsgBox "Sorry, this is not the correct password!", _
vbExclamation, "PRODUCT NAME"
Exit Sub
End If
'Get file contents
Open txtFile.Text For Input As #1
'Read past the header
Line Input #1, sHead
'Read and build the contents string
Do Until EOF(1)
Line Input #1, sT
sA = sA & sT
Loop
Close #1
'Decrypted file contents
cphX.KeyString = sHead
cphX.Text = sA
cphX.Shrink
cphX.DoXor
sA = cphX.Text
'Replace file with decrypted version
Kill txtFile.Text
Open txtFile.Text For Binary As #1
Put #1, , sA
Close #1
EncryptError123456:
MsgBox "Product Name, has finished decrypting your file.", vbExclamation, "PRODUCT NAME"
End Sub

Function Hash(sA As String) As String
Dim cphHash As New Cipher
cphHash.KeyString = sA & "OF COURSE, THIS IS OMITTED!"
cphHash.Text = sA & "OF COURSE, THIS IS OMITTED!"
cphHash.DoXor
cphHash.Stretch
cphHash.KeyString = cphHash.Text
cphHash.Text = "OF COURSE, THIS IS OMITTED!"
cphHash.DoXor
cphHash.Stretch
Hash = cphHash.Text
End Function

But I have no idea on how to make this loop so that it encrypts directories. Any help would be apreciated.
Oh, by the way, how do you make your code look like how VB displays it?

Did you get that code from the book "Visual basic Developers WorkShop 6.0" by Microsoft press? It sure looks familiar :)

Anyway, if I can remember rightly, the stretch method converts all characters into printable readable characters. So, if you are encrypting a bunch of JPEGS (porn? :)) in a directory or something, , which the contents are not in readable form (as is a text file) then it doesn't need to be stretched... I hope you know what i mean ;)

Just a suggestion ;)

To get code like this:

Code:

---

'Msgbox
Msgbox "Hello World!"

---

You have to place the code you want in between CODE tags.
I can't do it here, as it will be recognised, but in the following example, replace COD with CODE:
[COD]
'your VB code here
[/COD]

Laterz krew

REM

Quote:

---

Did you get that code from the book "Visual basic Developers WorkShop 6.0" by Microsoft press? It sure looks familiar

---

No, I didn't get it from that book. (I didn't get it from ANY book) But...I guess that great minds think alike! :)
Oh, BTW, I'm not encrypting porn. LOL I'm just stretching it so that in any case, VB will be able to intrepret it.

Matthew:
The code I posted will encrypt a file. However, there is no
error checking so if your path is wrong it goes on about
it's business and gives a message that the file is encrypted
when in fact it never found the file.

As for the strength of it's encryption, I don't know. It's
code that was passed to me via another Q & A at another place and time.

Have fun!

Someone,
Please answer this question! It is extremely important that I solve this problem.
Thanks