ENCRYPTAGE/DECRYPTAGE

Option Explicit
' ****************************************************************************
' *** Fonctions de cryptage/décryptage ******************************* 1.1 ***
' ****************************************************************************
' * N'hésitez pas à m'envoyer un mail si:                                    *
' * - Vous souhaitez me donnez vos impressions                               *
' * - Vous avez envie de me faire partager des modifications de code que vous*
' *   auriez faites.                                                         *
' ****************************************************************************
' * AUTEUR: FlyKiller.                                                       *
' ****************************************************************************
Private Const CodeChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-/"
Public Enum CryptMethods
  cmNumberOfTime
  cmRaiseLenght
End Enum
Private Enum BitCoding
  bc6Bits = 5
  bc8Bits = 7
End Enum

' ****************************************************************************
' *** FUNCTION CryptMsg ******************************************************
' *--------------------------------------------------------------------------*
' * PARAMETRES:                                                              *
' * - Msg: message à crypter.                                                *
' * - CryptMethod: spécifie si il faut crypter x fois (NumberOfTime) ou      *
' *                jusqu'à ce que le message crypté arrive à une taille      *
' *                limite (RaiseLength)                                      *
' * - CryptLimit: nombre de fois qu'il faut crypter (si NumberOfTime) ou     *
' *               taille maximale que le message crypté ne peut dépasser     *
' *               (si RaiseLength)                                           *
' *--------------------------------------------------------------------------*
' * VALEURS RETOURNEES:                                                      *
' * - Retour de la fonction: Message crypté.                                 *
' * - CryptLimit: Nombre de fois que le message a été réellement crypté.     *
' *               (Utile pour décrypter le message s'il a été encrypté       *
' *                plusieurs fois de suite)                                  *
' ****************************************************************************
Public Function CryptMsg(ByVal Msg As String, _
                         Optional ByVal CryptMethod As CryptMethods = cmNumberOfTime, _
                         Optional ByRef CryptLimit As Integer = 1) As String
Dim BS As String
Dim I As Integer

  If CryptMethod = cmNumberOfTime Then
    For I = 1 To CryptLimit
      BS = GetBitString(Msg, bc8Bits)
      Msg = GetConvertedString(BS, bc6Bits)
    Next
    CryptMsg = Msg
  Else
    I = 0
    While Len(Msg) < CryptLimit
      BS = GetBitString(Msg, bc8Bits)
      Msg = GetConvertedString(BS, bc6Bits)
      If Len(Msg) <= CryptLimit Then CryptMsg = Msg: I = I + 1
    Wend
    CryptLimit = I
  End If
End Function

' ****************************************************************************
' *** FUNCTION UncryptMsg ****************************************************
' ****************************************************************************
Public Function UncryptMsg(ByVal Msg As String, _
                Optional ByVal UncryptRepeat As Integer = 1) As String
Dim BS As String

  UncryptMsg = Msg
  While UncryptRepeat > 0
    BS = GetBitString(UncryptMsg, bc6Bits)
    BS = Mid$(BS, 1, (Len(BS) \ 8) * 8)
    UncryptMsg = GetConvertedString(BS, bc8Bits)
    UncryptRepeat = UncryptRepeat - 1
  Wend
End Function

' ****************************************************************************
' *** FUNCTION GetBitString **************************************************
' ****************************************************************************
Private Function GetBitString(ByVal Msg As String, _
                              ByVal BitPerChar As BitCoding) As String
Dim LetterIdx As Integer
Dim AscLetter As Integer
Dim BitIdx As Integer

  For LetterIdx = 1 To Len(Msg)
    If BitPerChar = bc8Bits Then
      AscLetter = Asc(Mid$(Msg, LetterIdx, 1))
    Else
      AscLetter = InStr(CodeChars, Mid$(Msg, LetterIdx, 1)) - 1
    End If
    For BitIdx = BitPerChar To 0 Step -1
      If AscLetter And 2 ^ BitIdx Then
        GetBitString = GetBitString & "1"
      Else
        GetBitString = GetBitString & "0"
      End If
    Next
  Next
End Function

' ****************************************************************************
' *** FUNCTION GetConvertedString ********************************************
' ****************************************************************************
Private Function GetConvertedString(ByVal BitString As String, _
                                    ByVal BitPerChar As BitCoding) As String
Dim LetterIdx As Integer
Dim AscLetter As Integer
Dim BitIdx As Integer

  For LetterIdx = 1 To Len(BitString) Step BitPerChar + 1
    AscLetter = 0
    For BitIdx = 0 To BitPerChar
      If Mid$(BitString, LetterIdx + BitIdx, 1) = "1" Then
        AscLetter = AscLetter Or (2 ^ (BitPerChar - BitIdx))
      End If
    Next
    If BitPerChar = bc8Bits Then
      GetConvertedString = GetConvertedString & Chr$(AscLetter)
    Else
      GetConvertedString = GetConvertedString & Mid$(CodeChars, AscLetter + 1, 1)
    End If
  Next
End Function