Text Verschlüsselung/Entschlüssellung
07.11.2016 23:33:39
Stefan
ich habe hier im Forum eine schöne Text Verschlüssellung per VBA gefunden.
Verschlüsseln tut der Code Prima aber Entschlüsseln funktioniert leider nicht richtig, vlt. kann ja einer von Euch das wirwar verstehen und den Code zum Laufen bringen. Würde mich riesig darüber freuen, weil ich genau sowas suche.
Hier der Code von Micha:
Function Verschlüsseln(ByVal s As String, key As Long) As String
Dim n As Long, i As Long, ss As String
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, t As Long
Static saltvalue As String * 4
For i = 1 To 4
t = 100 * (1 + Asc(Mid(saltvalue, i, 1))) * Rnd() * (Timer + 1)
Mid(saltvalue, i, 1) = Chr(t Mod 256)
Next
s = Mid(saltvalue, 1, 2) & s & Mid(saltvalue, 3, 2)
n = Len(s)
ss = Space(n)
ReDim sn(n) As Long
k1 = 11 + (key Mod 233)
k2 = 7 + (key Mod 239)
k3 = 5 + (key Mod 241)
k4 = 3 + (key Mod 251)
For i = 1 To n
sn(i) = Asc(Mid(s, i, 1))
Next
For i = 2 To n
sn(i) = sn(i) Xor sn(i - 1) Xor ((k1 * sn(i - 1)) Mod 256)
Next
For i = n - 1 To 1 Step -1
sn(i) = sn(i) Xor sn(i + 1) Xor (k2 * sn(i + 1)) Mod 256
Next
For i = 3 To n
sn(i) = sn(i) Xor sn(i - 2) Xor (k3 * sn(i - 1)) Mod 256
Next
For i = n - 2 To 1 Step -1
sn(i) = sn(i) Xor sn(i + 2) Xor (k4 * sn(i + 1)) Mod 256
Next
For i = 1 To n
Mid(ss, i, 1) = Chr(sn(i))
Next
Verschlüsseln = ss
End Function
Function Entschlüsseln(ByVal s As String, key As Long) As String
Dim n As Long, i As Long, ss As String
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long
n = Len(s)
ss = Space(n)
ReDim sn(n) As Long
k1 = 11 + (key Mod 233)
k2 = 7 + (key Mod 239)
k3 = 5 + (key Mod 241)
k4 = 3 + (key Mod 251)
For i = 1 To n
sn(i) = Asc(Mid(s, i, 1))
Next
For i = 1 To n - 2
sn(i) = sn(i) Xor sn(i + 2) Xor (k4 * sn(i + 1)) Mod 256
Next
For i = n To 3 Step -1
sn(i) = sn(i) Xor sn(i - 2) Xor (k3 * sn(i - 1)) Mod 256
Next
For i = 1 To n - 1
sn(i) = sn(i) Xor sn(i + 1) Xor (k2 * sn(i + 1)) Mod 256
Next
For i = n To 2 Step -1
sn(i) = sn(i) Xor sn(i - 1) Xor (k1 * sn(i - 1)) Mod 256
Next
For i = 1 To n
Mid(ss, i, 1) = Chr(sn(i))
Next i
Entschlüsseln = Mid(ss, 3, Len(ss) - 4)
End Function
Private Sub Encrypt()
Dim Schlüssel As Long
Dim s As String, ss As String
Dim ff As Byte
ff = FreeFile
Schlüssel = 5544 'Codierungsschlüssel
Open "c:\original.txt" For Input As ff
Open "c:\crypt.txt" For Output As ff + 1
Do While Not EOF(ff)
Input #ff, s
ss = Verschlüsseln(s, Schlüssel)
Print #ff + 1, ss
Loop
Close
Kill "c:\original.txt"
End Sub
Private Sub Decrypt()
Dim Schlüssel As Long
Dim s As String, ss As String
Dim ff As Byte
ff = FreeFile
Schlüssel = 5544 'Codierungsschlüssel
Open "c:\original.txt" For Output As ff
Open "c:\crypt.txt" For Input As ff + 1
Do While Not EOF(ff + 1)
Input #ff + 1, s
ss = Entschlüsseln(s, Schlüssel)
Print #ff, ss
Loop
Close
Kill "c:\crypt.txt"
End Sub
Stefan