Descargar

'// ==============================================================
'// MODULO DE ENCRIPTACIÓN
'// Modificado e implementado a Visual Basic por Harvet T.
'// Julio 2 de 1998
'// Los comentarios precedidos por // son de Harvey, los
'// demas son originales del código.
'// Derechos de reutilización solo para Aplicaciones.
'// ==============================================================
DefInt A-Z
Option Explicit
 
'//For Action parameter in EncryptString
Public Const ENCRYPT = 1, DECRYPT = 2
 
'-------------------------------------------------------------------------------------
' EncryptString
' Optimizing by Harvey T.
' EncryptString encodes/decodes a string.
' It's hard to explain so I'll show you an example using the EncryptString KEY:
'
' ORIGINAL rtn:              ENCRYPTION
' Text to code:              E   N   C   R   Y   P   T   I   O   N
' ASCII CODES:               69  78  67  82  89  80  84  73  79  78
' ENCRYPTION STRING:         K   E   Y   K   E   Y   K   E   Y   K
' ASCII CODES:               75  69  89  75  69  89  75  69  89  75
' ADD ASCII CODES:           144 147 156 157 158 169 159 142 168 153
' TRANSLATE TO CHARACTERS:   �   “   œ   �   ž   ©   Ÿ   Ž   ¨   ™
'
' ENCRYPTED rtn:             �“œ�ž©ŸŽ¨™
'
' UserKey = The key UserKey (should be user defined)
' Text    = The text to be encrypted/decrypted
' Action  = ENCRYPT, if you want to encrypt, or DECRYPT if you want to decrypt
'-------------------------------------------------------------------------------------
Public Function EncryptString(Text As String, Action As Single _
    ) As String
    Dim UserKeyX As String
    Dim Temp     As Integer
    Dim Times    As Integer
    Dim i        As Integer
    Dim j        As Integer
    Dim n        As Integer
    Dim rtn      As String
    Dim UserKey As String
    '//Get UserKey characters
    UserKey = "SIAC-UNJBG"
    n = Len(UserKey)
    ReDim UserKeyASCIIS(1 To n)
    For i = 1 To n
        UserKeyASCIIS(i) = Asc(Mid$(UserKey, i, 1))
    Next
 
    '//Get Text characters
    ReDim TextASCIIS(Len(Text)) As Integer
    For i = 1 To Len(Text)
        TextASCIIS(i) = Asc(Mid$(Text, i, 1))
    Next
 
    '//Encryption/Decryption
    If Action = ENCRYPT Then
       For i = 1 To Len(Text)
           j = IIf(j + 1 >= n, 1, j + 1)
           Temp = TextASCIIS(i) + UserKeyASCIIS(j)
           If Temp > 255 Then
              Temp = Temp - 255
           End If
           rtn = rtn + Chr$(Temp)
       Next
    ElseIf Action = DECRYPT Then
       For i = 1 To Len(Text)
           j = IIf(j + 1 >= n, 1, j + 1)
           Temp = TextASCIIS(i) - UserKeyASCIIS(j)
           If Temp < 0 Then
              Temp = Temp + 255
           End If
           rtn = rtn + Chr$(Temp)
       Next
    End If
 
    '//Return
    EncryptString = rtn
End Function
 
'//---------------------------------------------
'// Return a random string of ASCII Chart.
'// Used by ChrTran. By Harvey T.
'//---------------------------------------------
Public Function RandomChart() As String
    Dim Char    As String
    Dim RndStr  As String
    Dim n       As Integer
 
    Randomize Timer
    Do
       Char = Chr$(Int(Rnd * 256))
       If InStr(RndStr, Char) = 0 Then
          n = n + 1
          RndStr = RndStr + Char
       End If
    Loop Until n = 256
 
    RandomChart = RndStr
End Function
 
'-------------------------------------------------------------------------------------
' ChrTran
' Optimizing by Harvey T.
'
' This is a Function which transposes characters.
' It is excellent for doing simple encryption for passwords or anything.
'
' Here's how it works:
' Text    is the string you want to encode/decode
' SStr    is a search string. It is defined by you and should contain all
'         the keyboard characters that a user might type (AlphaNumeric, !, @, #,
'         etc.)
' EStr    is the encryption string.  It should contain the characters a user
'         will never type (the extended ascii set - œ,�,ž, etc.)
' ChrTran Takes each character of Text, finds its position in SStr, and
'         exchanges it for the character in the same position in EStr Function
'-------------------------------------------------------------------------------------
Public Function ChrTran(Text As String, SStr As String, EStr As String) As String
    Dim i   As Integer
    Dim rtn As String
 
    For i = 1 To Len(Text)
        rtn = rtn + Mid$(EStr, InStr(SStr, Mid$(Text, i, 1)), 1)
    Next
    ChrTran = rtn
End Function

Descargar