StringToBase Function [Source]

[xmbeat92]

bueno, este code lo hize el 14 de febrero(domingo), no mas porque si (no tenia nada que hacer, estoy solo como perro, jaja).
la funcion convierte el Texto a la base en la que se especifica (2 para binario, 16 para hexadecima, Etc), le puse un limite de base (35) porque se acabaron las letras del abecedario y no me parecio ponerles los valores despues de la 'Z'. El code quiza se puede optimizar, pero no he tenido tiempo de checkarlo (por las tareas, el servicio social, etc).

Código [Seleccionar] Expandir

'Autor: Xmbeat (JHCC)
'e-mail: xmbeat:-com, xmbeat@yahoo.com
'Fecha: 14 de Febrero del 2010
'Descripcion: Algoritmo para convertir el valor de la tabla _
asii/ansi (255) a otro sistema de base y viceversa
'You can distribute the code freely without eliminating these commentaries
'0x35 = 232W0W3G363C0W1Q152T36373G0W2R352U0W2A2R3A3B2V160W3B2Y2V350D0A0W0W1W2R33330W2D3C2T320W150Y273G0W1X302T320Y190W2J363C160D0A1Y333A2V0D0A0W0W1W2R33330W2E2Y2R35323A0W152036390W2C2V2R2U0W3B2Y2V0W2T3634342V353B3A160D0A1Y352U0W232W


'StringToBase Function:
'Strings: Cadena de texto la cual se desea toString/detoString
'toString: Valor Booleano, cuando es seteado a True Convierte el Texto a la Base, _
           Cuando esta en False se hace lo opuesto
'Base: Valor Byte que indica la base de conversion, si la base  tiene mas de 1 digito _
       se convierte en Alfanumerico. Los valores para Base deben ser mayor que 1 y _
       menor a 36 (solo se usa el Abecedario (A-Z) para alfanumerico)
Private Function StringToBase(Strings As String, Optional toString As Boolean = False, _
Optional Base As Byte = 2) As String
Dim I           As Long
Dim NS          As String
Dim TS          As String
Dim CT          As Integer
Dim E           As Integer
Dim Limit       As Integer
Dim Rest        As Integer
Dim toBase      As Integer
On Error GoTo fallo
If Base > 35 Then Err.Raise 6, , "La Base no puede ser mayor a 35"
If Base < 2 Then Err.Raise 6, , "La Base no puede ser menor a 2"
Rest = 256
Do Until Rest <= 1
   Limit = Limit + 1
   Rest = Rest \ Base
Loop
For I = 1 To Len(Strings) Step IIf(toString = True, Limit, 1)
   NS = ""
   CT = IIf(toString, 0, Asc(Mid(Strings, I, 1)))
   For E = 1 To Limit
       If toString Then
           If Len(Mid(Strings, I)) < Limit Then Exit For
           NS = Mid(Mid(Strings, I, Limit), Limit + 1 - E, 1)
           If IsNumeric(NS) = False Then NS = CStr(Asc(NS) - 55)
           CT = CT + Val(NS) * Base ^ (E - 1)
       Else
           toBase = CT Mod Base
           If toBase < 10 Then
               NS = CStr(toBase) & NS
           Else
               NS = Chr$(55 + toBase) & NS
           End If
           
           CT = CT \ Base
       End If
   Next
   TS = TS & IIf(toString, Chr(CT), NS)
Next
StringToBase = TS
Exit Function
fallo:
If Err.Number = 6 Then
   Err.Raise 6, , Err.Description
   Exit Function
End If
Err.Raise 1, , "El Texto no esta codificado con la base " _
           & Base & "  y por lo tanto no se puede DetoString"

End Function

Private Sub Form_Load()
Const Texto As String = "by xmbeat"
Dim Binario As String
Dim Hexa As String
AutoRedraw = True
Binario = StringToBase(Texto)
Hexa = StringToBase(Texto, , 16)
Print Binario
Print Hexa
Print StringToBase(Hexa, True, 16)
End Sub