Option Explicit
Public Sub text_verschlüsseln()
Debug.Print crypt("Testtext", "passwort", True)
End Sub
Private Function crypt(ByVal inp As String, ByVal pass As String, ByVal encrypt As Boolean) As String
Dim Key(24) As String
Dim i As Integer
Dim tmp As String
inp = LCase(inp)
pass = LCase(pass)
For i = 0 To 96
inp = replace(inp, Chr(i), "")
pass = replace(pass, Chr(i), "")
Next i
For i = 123 To 127
inp = replace(inp, Chr(i), "")
pass = replace(pass, Chr(i), "")
Next i
Call generate_key(Key(), pass)
For i = 1 To Len(inp)
tmp = tmp & get_character(Key, Mid(inp, i, 1), encrypt)
Next i
crypt = tmp
End Function
Private Sub generate_key(ByRef Key() As String, ByVal pass As String)
Dim i As Integer, j As Integer
Dim tmp As String, alphabet As String
alphabet = "abcdefghijklmopqrstuvwxyz"
pass = LCase(pass)
For i = 1 To Len(pass)
If InStr(1, pass, Mid(pass, i, 1), vbTextCompare) > 1 Then
tmp = replace(pass, Mid(pass, i, 1), "")
pass = tmp
End If
Next i
For i = 1 To Len(pass)
If InStr(1, alphabet, Mid(pass, i, 1), vbTextCompare) > 0 Then
alphabet = replace(alphabet, Mid(pass, i, 1), "")
End If
Next i
For i = 1 To Len(pass)
Key(i - 1) = Mid(pass, i, 1)
Next i
j = Len(pass)
For i = Len(alphabet) To 1 Step -1
Key(j) = Mid(alphabet, i, 1)
j = j + 1
Next i
End Sub
Private Function get_character(ByRef Key() As String, ByVal Char As String, ByVal encrypt As Boolean) As String
Dim alphabet As String
alphabet = "abcdefghijklmopqrstuvwxyz"
If encrypt Then
get_character = Key(InStr(1, alphabet, Char, vbTextCompare) - 1)
Else
Dim alpha(24) As String
Dim strKey As String
Dim i As Integer
For i = 0 To UBound(Key())
strKey = strKey & Key(i)
Next i
For i = 1 To Len(alphabet)
alpha(i - 1) = Mid(alphabet, i, 1)
Next i
get_character = alpha(InStr(1, strKey, Char, vbTextCompare) - 1)
End If
End Function