|
-
Jul 28th, 2000, 02:47 PM
#4
Thread Starter
PowerPoster
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?
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|