Nesecito encriptar una cadena

[elmonje]

Hola, necesito cifrar una cadena, el problema es que el resultado del cifrado deben ser caracteres de alfanumericos normales, de A-Z o de 0-9.
Sin caracteres raros, pero lo mas complicado es que el resultado de la cadena
ya cifrada no debe superar 150 caracteres, por mas que la cadena a cifrar contenga 300 caracteres.
Es posible?.

Gracias.

[GeoAvila]

usa md5 en las faq's hay un ejemplo..

nos vemos..

[seba123neo]

si es posible y en menos todavia!!!,mas o menos unos 40 caracteres para cualquier cadena.

aca tenes un ejemplo que usa el algoritmo sha1.por mas grande que sea la cadena a encriptar siempre se mantiene en los mas o menos 40 caracteres.

en el formulario pone 2 textbox,el primero va a ser para ingresar la cadena,y el segundo para visualizar la encriptacion.dos botones,el primero que al apretarlo encripta la cadena y el segundo es para abrir un archivo que quieras encriptar.y por su puesto un commondialog para poder abrir el archivo.

en un modulo clase pone:

Option Explicit
Private m_lOnBits(30) As Long
Private m_l2Power(30) As Long
Private Const BITS_TO_A_BYTE As Long = 8
Private Const BYTES_TO_A_WORD As Long = 4
Private Const BITS_TO_A_WORD As Long = BYTES_TO_A_WORD * BITS_TO_A_BYTE
Private Sub Class_Initialize()
m_lOnBits(0) = 1
m_lOnBits(1) = 3
m_lOnBits(2) = 7
m_lOnBits(3) = 15
m_lOnBits(4) = 31
m_lOnBits(5) = 63
m_lOnBits(6) = 127
m_lOnBits(7) = 255
m_lOnBits(8) = 511
m_lOnBits(9) = 1023
m_lOnBits(10) = 2047
m_lOnBits(11) = 4095
m_lOnBits(12) = 8191
m_lOnBits(13) = 16383
m_lOnBits(14) = 32767
m_lOnBits(15) = 65535
m_lOnBits(16) = 131071
m_lOnBits(17) = 262143
m_lOnBits(18) = 524287
m_lOnBits(19) = 1048575
m_lOnBits(20) = 2097151
m_lOnBits(21) = 4194303
m_lOnBits(22) = 8388607
m_lOnBits(23) = 16777215
m_lOnBits(24) = 33554431
m_lOnBits(25) = 67108863
m_lOnBits(26) = 134217727
m_lOnBits(27) = 268435455
m_lOnBits(28) = 536870911
m_lOnBits(29) = 1073741823
m_lOnBits(30) = 2147483647

m_l2Power(0) = 1
m_l2Power(1) = 2
m_l2Power(2) = 4
m_l2Power(3) = 8
m_l2Power(4) = 16
m_l2Power(5) = 32
m_l2Power(6) = 64
m_l2Power(7) = 128
m_l2Power(8) = 256
m_l2Power(9) = 512
m_l2Power(10) = 1024
m_l2Power(11) = 2048
m_l2Power(12) = 4096
m_l2Power(13) = 8192
m_l2Power(14) = 16384
m_l2Power(15) = 32768
m_l2Power(16) = 65536
m_l2Power(17) = 131072
m_l2Power(18) = 262144
m_l2Power(19) = 524288
m_l2Power(20) = 1048576
m_l2Power(21) = 2097152
m_l2Power(22) = 4194304
m_l2Power(23) = 8388608
m_l2Power(24) = 16777216
m_l2Power(25) = 33554432
m_l2Power(26) = 67108864
m_l2Power(27) = 134217728
m_l2Power(28) = 268435456
m_l2Power(29) = 536870912
m_l2Power(30) = 1073741824
End Sub
Private Function LShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function

ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * _
m_l2Power(iShiftBits)) Or &H80000000

Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * _
m_l2Power(iShiftBits))

End If
End Function
Private Function RShift(ByVal lValue As Long, _
ByVal iShiftBits As Integer) As Long

If iShiftBits = 0 Then
RShift = lValue
Exit Function

ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function

ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)

If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function AddUnsigned(ByVal lX As Long, _
ByVal lY As Long) As Long
Dim lX4 As Long
Dim lY4 As Long
Dim lX8 As Long
Dim lY8 As Long
Dim lResult As Long

lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000

lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If

AddUnsigned = lResult
End Function
Private Function LRot(ByVal x As Long, ByVal n As Long) As Long
LRot = LShift(x, n) Or RShift(x, (32 - n))
End Function
Private Function ConvertToWordArray(sMessage As String) As Long()
Dim lMessageLength As Long
Dim lNumberOfWords As Long
Dim lWordArray() As Long
Dim lBytePosition As Long
Dim lByteCount As Long
Dim lWordCount As Long
Dim lByte As Long

Const MODULUS_BITS As Long = 512
Const CONGRUENT_BITS As Long = 448

lMessageLength = Len(sMessage)

lNumberOfWords = (((lMessageLength + _
((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ _
(MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * _
(MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)

lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD

lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE

lByte = AscB(Mid(sMessage, lByteCount + 1, 1))

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(lByte, lBytePosition)
lByteCount = lByteCount + 1
Loop

lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or _
LShift(&H80, lBytePosition)

lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)

ConvertToWordArray = lWordArray
End Function
Public Function SHA1(sMessage As String) As String
Dim HASH(4) As Long
Dim M() As Long
Dim W(79) As Long
Dim a, b, c, d, e As Long
Dim g, h, i, j As Long
Dim T1, T2 As Long

HASH(0) = &H67452301
HASH(1) = &HEFCDAB89
HASH(2) = &H98BADCFE
HASH(3) = &H10325476
HASH(4) = &HC3D2E1F0

M = ConvertToWordArray(sMessage)

For i = 0 To UBound(M) Step 16
a = HASH(0)
b = HASH(1)
c = HASH(2)
d = HASH(3)
e = HASH(4)

For g = 0 To 15
W(g) = M(i + g)
Next g

For g = 16 To 79
W(g) = LRot(W(g - 3) Xor W(g - 8) Xor W(g - 14) Xor W(g - 16), 1)
Next g

For j = 0 To 79

If j <= 19 Then
T1 = (b And c) Or ((Not b) And d)
T2 = &H5A827999
ElseIf j <= 39 Then
T1 = b Xor c Xor d
T2 = &H6ED9EBA1
ElseIf j <= 59 Then
T1 = (b And c) Or (b And d) Or (c And d)
T2 = &H8F1BBCDC
ElseIf j <= 79 Then
T1 = b Xor c Xor d
T2 = &HCA62C1D6
End If

h = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(LR ot(a, 5), T1), e), T2), W(j))
e = d
d = c
c = LRot(b, 30)
b = a
a = h
Next j

HASH(0) = AddUnsigned(a, HASH(0))
HASH(1) = AddUnsigned(b, HASH(1))
HASH(2) = AddUnsigned(c, HASH(2))
HASH(3) = AddUnsigned(d, HASH(3))
HASH(4) = AddUnsigned(e, HASH(4))

Next i

SHA1 = LCase(Right("00000000" & Hex(HASH(0)), 8) & _
Right("00000000" & Hex(HASH(1)), 8) & _
Right("00000000" & Hex(HASH(2)), 8) & _
Right("00000000" & Hex(HASH(3)), 8) & _
Right("00000000" & Hex(HASH(4)), 8))
End Function

y en el formulario pone:

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Command1_Click()
Dim oSHA1 As New clsSHA1
Dim LngStart, LngEnd As Long
LngStart = GetTickCount
Text2.Text = oSHA1.SHA1(Text1.Text)
LngEnd = GetTickCount
Set oSHA1 = Nothing
MsgBox "la encriptacion duro " & LngEnd - LngStart & "milisegundos"
End Sub
Private Function BinaryRead(ByRef sFileName As String) As String
Dim fh As Integer
fh = FreeFile

Open sFileName For Binary As #fh
BinaryRead = Input$(LOF(fh), fh)
Close #fh
End Function

Private Sub Command2_Click()
With CommonDialog1
.Filter = "*.*"
.DialogTitle = "seleciona el archivo a encriptar"
.ShowOpen
If .FileName = "" Then Exit Sub
End With
Dim oSHA1 As New clsSHA1
Dim LngStart, LngEnd As Long
Dim sFile As String
Me.MousePointer = 11
sFile = BinaryRead(CommonDialog1.FileName)
LngStart = GetTickCount
Text2.Text = oSHA1.SHA1(sFile)
LngEnd = GetTickCount
Set oSHA1 = Nothing
Me.MousePointer = 0
MsgBox "la encriptacion duro: " & LngEnd - LngStart & "milisegundos" & vbCrLf & "on a " & Format(Len(sFile), "###,###,###,##0") & " byte file."
End Sub