by Adam Melton (5 Submissions)
Category: Encryption
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Mon 23rd May 2005
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Complicated encryption/ decryption function
VBcoders
Dim intloop As Integer
Dim intloop2 As Integer
Dim Rand As Integer
Dim intRand As Integer
Dim start As Integer
Dim CS As String
Dim CS2
Dim CS3
On Error Resume Next
CS = ""
CS2 = StrString
CS3 = ""
Randomize
If Decrypt = True Then
If Len(CS) Mod 2 = 0 Then
For intloop2 = 1 To 3
CS = ""
For intloop = 1 To Len(CS2) Step 6
CS = CS & Chr(Mid(CS2, intloop, 2))
Next intloop
CS2 = CS
Next intloop2
CS = CS2
CS2 = ""
For intloop = 1 To Len(CS) / 2 Step 1
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
For intloop = Len(CS) / 2 + 1 To Len(CS) Step 1
CS3 = CS3 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop = 1 To Len(CS3) + Len(CS2) Step 1
CS = CS & Mid(CS3, intloop, 1) & Mid(CS2, intloop, 1)
Next intloop
CS2 = ""
For intloop = Len(CS) To 1 Step -1
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop = 1 To Len(CS2) / 2 Step 1
CS = CS & Mid(CS2, intloop, 1)
Next intloop
CS3 = ""
For intloop = Len(CS) To 1 Step -1
CS3 = CS3 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop = Len(CS2) / 2 + 1 To Len(CS2) Step 1
CS = CS & Mid(CS2, intloop, 1)
Next intloop
CS2 = CS
CS = ""
For intloop = 1 To Len(CS2) Step 1
CS = CS & Mid(CS2, intloop, 1) & Mid(CS3, intloop, 1)
Next intloop
CS2 = CS
CS = ""
CS3 = ""
Else
For intloop2 = 1 To 3
CS = ""
For intloop = 1 To Len(CS2) Step 6
CS = CS & Chr(Mid(CS2, intloop, 2))
Next intloop
CS2 = CS
Next intloop2
MsgBox CS
CS = CS2
CS2 = ""
For intloop = 1 To Len(CS) / 2 Step 1
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
For intloop = Len(CS) / 2 + 1 To Len(CS) Step 1
CS3 = CS3 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop = 1 To Len(CS3) + Len(CS2) Step 1
CS = CS & Mid(CS3, intloop, 1) & Mid(CS2, intloop, 1)
Next intloop
CS2 = ""
For intloop = Len(CS) To 1 Step -1
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop = 1 To Len(CS2) / 2 Step 1
CS = CS & Mid(CS2, intloop, 1)
Next intloop
CS3 = ""
For intloop = Len(CS) To 1 Step -1
CS3 = CS3 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop = Len(CS2) / 2 + 1 To Len(CS2) Step 1
CS = CS & Mid(CS2, intloop, 1)
Next intloop
CS2 = CS
CS = ""
For intloop = 1 To Len(CS2) Step 1
CS = CS & Mid(CS2, intloop, 1) & Mid(CS3, intloop, 1)
Next intloop
CS2 = CS
CS = ""
CS3 = ""
End If
ElseIf Decrypt = False Then
CS = ""
If Len(CS2) Mod 2 = 0 Then
For intloop = 2 To Len(CS2) Step 2
CS = CS & Mid(CS2, intloop, 1)
Next intloop
For intloop = Len(CS) To 1 Step -1
CS3 = CS3 & Mid(CS, intloop, 1)
Next intloop
CS = CS3
CS3 = ""
For intloop = 1 To Len(CS2) - 1 Step 2
Next intloop
CS2 = CS
CS = ""
For intloop = Len(CS2) To 1 Step -1
Next intloop
CS2 = ""
For intloop = 2 To Len(CS) Step 2
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
For intloop = 1 To Len(CS) - 1 Step 2
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
For intloop2 = 1 To 3
CS = ""
For intloop = 1 To Len(CS2) Step 1
Rand = Rand - Rand
For intRand = 1 To 4 Step 1
Rand = Rand & Int((9 - 1 + 1) * Rnd + 1)
Next intRand
CS = CS & Asc(Mid(UCase(CS2), intloop, 1)) & Rand
Next intloop
CS2 = CS
Next intloop2
CS = ""
Else
CS2 = CS2 & Mid(CS2, Len(CS2), 1)
MsgBox CS2
For intloop = 2 To Len(CS2) Step 2
CS = CS & Mid(CS2, intloop, 1)
Next intloop
For intloop = Len(CS) To 1 Step -1
CS3 = CS3 & Mid(CS, intloop, 1)
Next intloop
CS = CS3
CS3 = ""
For intloop = 1 To Len(CS2) - 1 Step 2
CS = CS & Mid(CS2, intloop, 1)
Next intloop
CS2 = CS
CS = ""
For intloop = Len(CS2) To 1 Step -1
CS = CS & Mid(CS2, intloop, 1)
Next intloop
CS2 = ""
For intloop = 2 To Len(CS) Step 2
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
For intloop = 1 To Len(CS) - 1 Step 2
CS2 = CS2 & Mid(CS, intloop, 1)
Next intloop
CS = ""
For intloop2 = 1 To 3
CS = ""
For intloop = 1 To Len(CS2) Step 1
Rand = Rand - Rand
For intRand = 1 To 4 Step 1
Rand = Rand & Int((9 - 1 + 1) * Rnd + 1)
Next intRand
CS = CS & Asc(Mid(UCase(CS2), intloop, 1)) & Rand
Next intloop
CS2 = CS
Next intloop2
End If
End If
Cryptt = CS2
End Function
