Ayuda para crear encriptador de texto a base64 en vb6.0

[Anonx]

hola a todos, estoy creando un proyecto que tenga varios encriptadores, como binario, hex...  y en mi caso necesito saber como poner para que escribas en el form algo en el textbox y pulsar en cifrar a base64 y se encripte, gracias

[LeandroA]

Hola te paso de dos forma la primera un modulo clase llamado Base64Class y la segunda al estilo vbscript.

Base64Class

Código (Vb) [Seleccionar] Expandir


Option Explicit

Private Const Equals As Byte = 61    'Asc("=")

Private Const Mask1 As Byte = 3      '00000011
Private Const Mask2 As Byte = 15     '00001111
Private Const Mask3 As Byte = 63     '00111111
Private Const Mask4 As Byte = 192    '11000000
Private Const Mask5 As Byte = 240    '11110000
Private Const Mask6 As Byte = 252    '11111100

Private Const Shift2 As Byte = 4
Private Const Shift4 As Byte = 16
Private Const Shift6 As Byte = 64

Private Base64Lookup() As Byte
Private Base64Reverse() As Byte

Public Function EncodeString(Text As String) As String

  Dim Data() As Byte
 
  Data = StrConv(Text, vbFromUnicode)
  EncodeString = EncodeByteArray(Data)

End Function

Public Function EncodeByteArray(Data() As Byte) As String

  Dim EncodedData() As Byte

  Dim DataLength As Long
  Dim EncodedLength As Long

  Dim Data0 As Long
  Dim Data1 As Long
  Dim Data2 As Long

  Dim l As Long
  Dim m As Long

  Dim Index As Long

  Dim CharCount As Long

  DataLength = UBound(Data) + 1

  EncodedLength = (DataLength \ 3) * 4
  If DataLength Mod 3 > 0 Then EncodedLength = EncodedLength + 4
  EncodedLength = EncodedLength + ((EncodedLength \ 76) * 2)
  If EncodedLength Mod 78 = 0 Then EncodedLength = EncodedLength - 2
  ReDim EncodedData(EncodedLength - 1)

  m = (DataLength) Mod 3

  For l = 0 To UBound(Data) - m Step 3
     Data0 = Data(l)
     Data1 = Data(l + 1)
     Data2 = Data(l + 2)
     EncodedData(Index) = Base64Lookup(Data0 \ Shift2)
     EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
     EncodedData(Index + 2) = Base64Lookup(((Data1 And Mask2) * Shift2) Or (Data2 \ Shift6))
     EncodedData(Index + 3) = Base64Lookup(Data2 And Mask3)
     Index = Index + 4
     CharCount = CharCount + 4

     If CharCount = 76 And Index < EncodedLength Then
        EncodedData(Index) = 13
        EncodedData(Index + 1) = 10
        CharCount = 0
        Index = Index + 2
     End If
  Next

  If m = 1 Then
     Data0 = Data(l)
     EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
     EncodedData(Index + 1) = Base64Lookup((Data0 And Mask1) * Shift4)
     EncodedData(Index + 2) = Equals
     EncodedData(Index + 3) = Equals
     Index = Index + 4
  ElseIf m = 2 Then
     Data0 = Data(l)
     Data1 = Data(l + 1)
     EncodedData(Index) = Base64Lookup((Data0 \ Shift2))
     EncodedData(Index + 1) = Base64Lookup(((Data0 And Mask1) * Shift4) Or (Data1 \ Shift4))
     EncodedData(Index + 2) = Base64Lookup((Data1 And Mask2) * Shift2)
     EncodedData(Index + 3) = Equals
     Index = Index + 4
  End If

  EncodeByteArray = StrConv(EncodedData, vbUnicode)

End Function

Public Function DecodeToString(EncodedText As String) As String

  Dim Data() As Byte
 
  Data = DecodeToByteArray(EncodedText)
  DecodeToString = StrConv(Data, vbUnicode)

End Function

Public Function DecodeToByteArray(EncodedText As String) As Byte()

  Dim Data() As Byte
  Dim EncodedData() As Byte

  Dim DataLength As Long
  Dim EncodedLength As Long

  Dim EncodedData0 As Long
  Dim EncodedData1 As Long
  Dim EncodedData2 As Long
  Dim EncodedData3 As Long

  Dim l As Long
  Dim m As Long

  Dim Index As Long

  Dim CharCount As Long

  EncodedData = StrConv(Replace$(Replace$(EncodedText, vbCrLf, ""), "=", ""), vbFromUnicode)

  EncodedLength = UBound(EncodedData) + 1
  DataLength = (EncodedLength \ 4) * 3

  m = EncodedLength Mod 4
  If m = 2 Then
     DataLength = DataLength + 1
  ElseIf m = 3 Then
     DataLength = DataLength + 2
  End If

  ReDim Data(DataLength - 1)

  For l = 0 To UBound(EncodedData) - m Step 4
     EncodedData0 = Base64Reverse(EncodedData(l))
     EncodedData1 = Base64Reverse(EncodedData(l + 1))
     EncodedData2 = Base64Reverse(EncodedData(l + 2))
     EncodedData3 = Base64Reverse(EncodedData(l + 3))
     Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
     Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
     Data(Index + 2) = ((EncodedData2 And Mask1) * Shift6) Or EncodedData3
     Index = Index + 3
  Next

  Select Case ((UBound(EncodedData) + 1) Mod 4)
  Case 2
     EncodedData0 = Base64Reverse(EncodedData(l))
     EncodedData1 = Base64Reverse(EncodedData(l + 1))
     Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
  Case 3
     EncodedData0 = Base64Reverse(EncodedData(l))
     EncodedData1 = Base64Reverse(EncodedData(l + 1))
     EncodedData2 = Base64Reverse(EncodedData(l + 2))
     Data(Index) = (EncodedData0 * Shift2) Or (EncodedData1 \ Shift4)
     Data(Index + 1) = ((EncodedData1 And Mask2) * Shift4) Or (EncodedData2 \ Shift2)
  End Select

  DecodeToByteArray = Data

End Function

Private Sub Class_Initialize()

  Dim l As Long
 
  ReDim Base64Reverse(255)
 
  Base64Lookup = StrConv("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/", vbFromUnicode)
 
  For l = 0 To 63
     Base64Reverse(Base64Lookup(l)) = l
  Next
 
End Sub


mas corta

Código (vb) [Seleccionar] Expandir



Public Function DecodeBase64(ByVal strData As String) As Byte()
   Dim objXML As Object
   Dim objNode As Object

   Set objXML = CreateObject("MSXML2.DOMDocument")
   Set objNode = objXML.createElement("b64")
   objNode.dataType = "bin.base64"
   objNode.Text = strData
   DecodeBase64 = objNode.nodeTypedValue

   Set objNode = Nothing
   Set objXML = Nothing

End Function


Public Function EnecodeBase64(ByVal strData As String) As Byte()
   Dim objStream As Object
   Dim objNode As Object
   Dim objXML As Object
   Dim bArray() As Byte

   Set objStream = CreateObject("ADODB.Stream")
   
   With objStream
       .Type = 2
       .Open
       .Charset = "unicode"
       .WriteText strData
       .Flush
       .Position = 0
       .Type = 1
       .read (2)
       bArray = .read
       .Close
   End With
   
   Set objXML = CreateObject("MSXML2.DOMDocument")
   Set objNode = objXML.createElement("b64")
       
   objNode.dataType = "bin.base64"
   objNode.nodeTypedValue = bArray
   EnecodeBase64 = objNode.Text
   
   Set objStream = Nothing
   Set objNode = Nothing
   Set objXML = Nothing

End Function


[Anonx]

muchas gracias, de verdad

[Karcrack]

Aprovecho para apuntar que base64 no es un cifrado sino una codificación.