Attribute VB_Name = "Verschluelsselung"
Option Explicit

Const CodeChr As String = "0123456789abcdefghijklmnopqrstuvwxyz!?#%-+"
Const MultPl As Long = 71

Public Function KeyPassw(Passw As String) As String
  Dim I As Integer
  Dim I2 As Double
  Dim I3 As Byte
  Dim LastByte As Byte
  Dim Erg As String
  For I = 1 To Len(Passw)
    LastByte = I3
    I2 = AscB(Mid(Passw, I, 1))
    I3 = I2
    I2 = I2 + 13 + (255 * 3 - LastByte * 3) + 13 * I
    Do While I2 > 255
      I2 = I2 - 256
    Loop
    Erg = Erg + Format(I2, "000")
  Next
  KeyPassw = "[//Coded:" + Erg + "]"
End Function

Public Function DeKeyPassw(Passw As String) As String
  Dim I As Integer
  Dim I2 As Double
  Dim LastByte As Integer
  Dim Erg As String
  If Left(Passw, 9) = "[//Coded:" Then
    For I = 10 To Len(Passw) Step 3
      If I > Len(Passw) - 3 Then Exit For
      LastByte = I2
      I2 = Val(Mid(Passw, I, 3))
      I2 = I2 - 13 - (255 * 3 - LastByte * 3) - 13 * ((I - 10) / 3 + 1)
      Do While I2 < 0
        I2 = I2 + 256
      Loop
      If I2 < 256 Then Erg = Erg + Chr(I2)
    Next
  Else
    Erg = Passw
  End If
  DeKeyPassw = Erg
End Function

Public Function EncodeText(Text As String, AktivMode As Boolean, Passw As String) As String
  'Codieren
  If AktivMode Then
    EncodeText = sEncodeText(EncodeUTF8(Text), Passw)
  Else
    EncodeText = Text
  End If
End Function

Public Function DecodeText(Text As String, WasCoded As Boolean, Passw As String) As String
  'Decodieren
  If Left(Text, 6) = "[NTCTC" And Mid(Text, 10, 1) = "|" And Right(Text, 1) = "]" Then
    DecodeText = DecodeUTF8(sDecodeText(Text, Passw))
    WasCoded = True
  Else
    DecodeText = Text
    WasCoded = False
  End If
End Function

Private Function sEncodeText(Text As String, Passw As String) As String
  Dim DAT As String
  Dim DIn As String
  Dim I As Long
  Dim CharVal As Long
  Dim LastCVal As Long
  Dim TPass As Long
  
  TPass = GetBinPW(Passw)
  DIn = Text + "<>"
  DAT = Space(Len(DIn) * 2)
  For I = 1 To Len(DIn)
    CharVal = AscB(Mid(DIn, I, 1)) + 256 * Int(Rnd * 5)
    
    CharVal = CharVal + TPass - MultPl * I + LastCVal * (13 + I * 7)
    
    CharVal = CharVal Mod 1764
    If CharVal < 0 Then CharVal = CharVal + 1764
    Mid(DAT, I * 2 - 1) = Mid(CodeChr, CharVal Mod 42 + 1, 1)
    Mid(DAT, I * 2, 1) = Mid(CodeChr, CharVal \ 42 + 1, 1)
    LastCVal = CharVal \ 42 + 1
  Next

  sEncodeText = "[NTCTC001|" + DAT + "]"
End Function

Private Function sDecodeText(Text As String, Passw As String) As String
  Dim DAT As String
  Dim I As Integer
  Dim I2 As Integer
  Dim I3 As Integer
  Dim CharVal As Long
  Dim LastCVal As Long
  Dim TErr As Integer
  Dim TPass As Long
  
  TPass = GetBinPW(Passw)
  DAT = Space((Len(Text) - 11) / 2)
  For I = 1 To Len(DAT)
    For I2 = 1 To 42
      If Mid(Text, I * 2 + 9, 1) = Mid(CodeChr, I2, 1) Then Exit For
    Next
    For I3 = 1 To 42
      If Mid(Text, I * 2 + 10, 1) = Mid(CodeChr, I3, 1) Then Exit For
    Next
    If I2 > 42 Or I3 > 42 Then
      TErr = 2
    Else
      CharVal = (I3 - 1) * 42 + (I2 - 1)
      
      CharVal = CharVal - TPass + MultPl * I - LastCVal * (13 + I * 7)
      
      CharVal = CharVal Mod 1764
      If CharVal < 0 Then CharVal = CharVal + 1764
      LastCVal = I3
    End If
    Mid(DAT, I, 1) = Chr(CharVal Mod 256)
  Next
  If Right(DAT, 2) <> "<>" Then TErr = 3
  If TErr = 0 Then
    sDecodeText = Left(DAT, Len(DAT) - 2)
  Else
    sDecodeText = Text
  End If
End Function

Public Function GetBinPW(Passw As String) As Long
  Dim I As Integer
  Dim Ergpw As Long
  
  For I = 1 To Len(Passw)
    If I > 20 Then Exit For
    Ergpw = Ergpw + (128 \ (I * 3.3)) ^ I * AscB(Mid(Passw, I, 1))
    'Debug.Print (128 \ (I * 3.3)) ^ I
  Next
  GetBinPW = Ergpw
End Function


