client/ClasesModulos/Registro.vb

'******************************
'octubre 2005
'Comentado por No<4E> S<>nchez

'Pernite encriptar y desencriptar el password 
Module Registro


    Public Function DesEncripta(ByVal Palabra As String) As String
        'funcion que toma como parametro un string y lo desencripta
        Dim Llave As String, Binario As String

        If Len(Palabra) >= 6 Then
            Binario = ConvetStringNumToBinary(Palabra)
            Binario = Mid(Binario, 5, Len(Binario) - 8)
            Llave = ConvetBinaryToString(Binario)
        Else
            Llave = ""
        End If
        DesEncripta = Llave
    End Function


    Function ConvetBinaryToString(ByVal Txt As String) As String
        'funcion que toma como parametro un string  en binario y lo convierte a un string 
        Dim ValorResultado As String
        Dim i As Integer
        Txt = Trim(Txt)
        For i = 1 To Len(Txt) Step 8
            ValorResultado = ValorResultado & ConvertBinaryToChar(Mid(Txt, i, 8))
        Next
        ConvetBinaryToString = ValorResultado
    End Function


    Function ConvertBinaryToChar(ByVal Caracter As String) As String
        'Funcion que toma como parametro un caracter en formato binario
        Dim ValorAscii As Byte
        Dim ValorTxt As String
        Dim Division As Integer
        Dim i As Integer
        Dim Resultado As Integer
        ValorTxt = ""
        If Len(Caracter) = 8 Then
            For i = Len(Caracter) To 1 Step -1
                ValorTxt = Mid(Caracter, i, 1)
                If ValorTxt = "1" Then
                    Resultado = Resultado + Potencia(2, 8 - i)
                End If
            Next
            ConvertBinaryToChar = Chr(Resultado)
        Else
            ConvertBinaryToChar = ""
        End If
    End Function


    Public Function Encripta(ByVal Palabra As String) As String
        'funcion que toma como parametro un string y lo encripta
        Dim Llave As String, Binario As String
        Binario = "1111" & ConvetStringToBinary(Palabra) & "1111"
        Llave = ConvetBinaryToStringNum(Binario)
        Encripta = Llave
    End Function


    Function ConvetStringToBinary(ByVal Txt As String) As String
        Dim ValorResultado As String
        Dim i As Integer
        Txt = Trim(Txt)
        For i = 1 To Len(Txt)
            ValorResultado = ValorResultado & ConvertCharToBinary(Mid(Txt, i, 1))
        Next
        ConvetStringToBinary = ValorResultado
    End Function


    Function ConvertCharToBinary(ByVal Caracter As String) As String

        Dim ValorAscii As Byte
        Dim ValorTxt As String
        Dim Division As Integer
        ValorTxt = ""
        If Len(Caracter) = 1 Then
            ValorAscii = Asc(Caracter)
            Do
                Division = Int(ValorAscii / 2)
                ValorTxt = IIf(ValorAscii Mod 2 = 1, "1", "0") & ValorTxt
                ValorAscii = Division
            Loop While (Division > 0)
            ConvertCharToBinary = Mid("00000000", 1, 8 - Len(ValorTxt)) & ValorTxt
        Else
            ConvertCharToBinary = "00000000"
        End If

    End Function


    Function ConvetStringNumToBinary(ByVal Txt As String) As String
        Dim ValorResultado As String
        Dim i As Integer
        Txt = Trim(Txt)
        For i = 1 To Len(Txt) Step 3
            ValorResultado = ValorResultado & ConvertNumToBinary(Mid(Txt, i, 3))
        Next
        ConvetStringNumToBinary = ValorResultado
    End Function


    Function ConvertNumToBinary(ByVal Caracter As String) As String
        Dim ValorTxt As String
        Dim Division As Integer
        ValorTxt = ""
        If Len(Caracter) = 3 Then
            Do
                Division = Int(Caracter / 2)
                ValorTxt = IIf(Caracter Mod 2 = 1, "1", "0") & ValorTxt
                Caracter = Division
            Loop While (Division > 0)
            ConvertNumToBinary = Mid("00000000", 1, 8 - Len(ValorTxt)) & ValorTxt
        Else
            ConvertNumToBinary = ""
        End If
    End Function


    Function ConvetBinaryToStringNum(ByVal Txt As String) As String
        Dim ValorResultado As String
        Dim i As Integer
        Txt = Trim(Txt)
        For i = 1 To Len(Txt) Step 8
            ValorResultado = ValorResultado & ConvertBinaryToNum(Mid(Txt, i, 8))
        Next
        ConvetBinaryToStringNum = ValorResultado
    End Function


    Function ConvertBinaryToNum(ByVal Caracter As String) As String
        Dim ValorAscii As Byte
        Dim ValorTxt As String
        Dim Division As Integer
        Dim i As Integer
        Dim Resultado As Integer
        Dim ResFinal As String
        ValorTxt = ""
        ResFinal = ""
        If Len(Caracter) = 8 Then
            For i = Len(Caracter) To 1 Step -1
                ValorTxt = Mid(Caracter, i, 1)
                If ValorTxt = "1" Then
                    Resultado = Resultado + Potencia(2, 8 - i)
                End If
            Next
            ResFinal = Resultado
            ConvertBinaryToNum = Mid("000", 1, 3 - Len(ResFinal)) & Resultado
        Else
            ConvertBinaryToNum = ""
        End If
    End Function


    Function Potencia(ByVal Base As Integer, ByVal Pot As Integer) As Long
        Dim Result As Long
        Dim i As Integer
        If Pot = 0 Then
            Result = 1
        Else
            Result = 1
            For i = 1 To Pot
                Result = Result * Base
            Next
        End If
        Potencia = Result
    End Function

End Module