Encryptage/decryptage

Commenter

Contenu du snippet

Le code se compose de deux fonctions publiques vous permettant d'encrypter et de décrypter un message. L'aspect intérressant réside dans le fait que vous pouvez crypter un message soit un nombre de fois, soit jusqu'à ce qu'il atteigne une certaine taille.

La méthode de cryptage est basée sur la conversion des caractères du code ASCII (8-bits) vers un autre dictionnaire (6-bits). Si vous avez des questions sur le code, n'hésitez pas à me contacter.

Sauvez le code dans un module et amusez-vous.

Source / Exemple : 


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

Conclusion :


(06-02-2000) Version 1.1: La fonction de décryptage ne fonctionnait pas quand on décryptait plusieurs fois de suite: c'est corrigé. Merci E. Coquinot.

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_FlyKiller)