Solved

VB Source for BASE64 function?

Posted on 1998-09-24
15
396 Views
Last Modified: 2010-04-30
Can anybody post the Visual Basic source code for a function that inputs a string and returns the string in BASE64?
0
Comment
Question by:alweiner
15 Comments
 
LVL 3

Expert Comment

by:a111a111a111
ID: 1436546
0
 
LVL 1

Author Comment

by:alweiner
ID: 1436547
All the comments appear to be in Japanese (there's much more there than just the Base64 routine)

Anybody have something in English? (Sorry, I should have been more specific in my request :)
0
 
LVL 18

Expert Comment

by:deighton
ID: 1436548
Here's two function you could add to your project either as a bas module or put the functions in your form.  Not

Public Function BASE64(sNumber As String)

    Dim lNumber As Long
   
    Dim iRem As Integer
   
    lNumber = Val(sNumber)
   
    While lNumber <> 0
   
        iRem = lNumber Mod 64
        lNumber = lNumber \ 64
       
        BASE64 = pad(iRem) & IIf(BASE64 <> "", " ", "") & BASE64
       
    Wend
       
    If BASE64 = "" Then BASE64 = "00"
       

End Function

Private Function pad(iNum As Integer)

    pad = CStr(iNum)
    If Len(pad) < 2 Then
        pad = "0" & pad
    End If

End Function

0
 
LVL 18

Expert Comment

by:deighton
ID: 1436549


      Public Function BASE64(sNumber As String)

          Dim lNumber As Long
           
          Dim iRem As Integer
           
          lNumber = Val(sNumber)
           
          While lNumber <> 0
           
              iRem = lNumber Mod 64
              lNumber = lNumber \ 64
               
              BASE64 = pad(iRem) & IIf(BASE64 <> "", " ", "") & BASE64
               
          Wend
               
          If BASE64 = "" Then BASE64 = "00"
               

      End Function

      Private Function pad(iNum As Integer)

          pad = CStr(iNum)
          If Len(pad) < 2 Then
              pad = "0" & pad
          End If

      End Function
0
 
LVL 18

Expert Comment

by:deighton
ID: 1436550
Hope thats what you mean by base 64 by the way I'm assuming you want number base 64 i.e 65 would be 01 01, 66 = 01 02 etc...  
0
 
LVL 1

Author Comment

by:alweiner
ID: 1436551
Thanks, but that only returns the base64 value if the string input is a number in string form.  I need a generic base64 function that works for any string.
0
 
LVL 18

Expert Comment

by:deighton
ID: 1436552
Could you be more specific, what would you want the function to dow with the string "AD" for example?

Could you explain what you mean by base64?
0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 1

Author Comment

by:alweiner
ID: 1436553
Base64 is a standard encoding technique -- usually used for password transmission.
0
 
LVL 18

Expert Comment

by:deighton
ID: 1436554
Private Function base64a(sString As String)

    Dim c As Long
    Dim iLeft As Integer, iRight As Integer
   
    For c = 1 To Len(sString)
   
        ival = Asc(Mid(sString, c, 1))
       
        iLeft = ival \ 64
        iRight = ival Mod 64
       
        base64a = base64a + IIf(base64a <> "", " ", "") + CStr(iLeft) + CStr(iRight)
       
    Next
       

End Function
0
 
LVL 1

Author Comment

by:alweiner
ID: 1436555
Pls don't just guess if you don't know.  Does anybody understand BASE64 and have VB source code to do it?
0
 
LVL 12

Expert Comment

by:mark2150
ID: 1436556
BASE64 is part of MIME encoding. It converts three binary bytes into four printable ASCII characters and back again.

I have versions in both compiled QBASIC and VB5. Too big to send here.

Email me at mark_lambert@ntsc.navy.mil and I'll forward the code. In the meantime the MIME decoder is posted on my web site: www.hostpc.net/madmark.

M

0
 
LVL 1

Author Comment

by:alweiner
ID: 1436557
I just emailed you - thanx...
0
 
LVL 18

Expert Comment

by:deighton
ID: 1436558
This isn't a guess so Ill send it to you.  

encode64 and decode64 are my functions designed to use the Japanese version as specified


Public Function encode64(sX As String) As String

'Encode to a string from a string

    Dim x() As Byte
    Dim iLen As Long, c As Long
    Dim sString As String
   
    iLen = Len(sX)
    ReDim x(iLen - 1)
   
    For c = 0 To iLen - 1
   
        x(c) = Asc(Mid(sX, c + 1, 1))
       
    Next
   
    Call base64encode(x, iLen, sString)
   
    encode64 = sString


End Function

Public Function decode64(x As String) As String

'decode from a string to  a string

    Dim n() As Byte
    Dim ni As Long
    Dim sString As String
   
    ReDim n(Len(x) + 1)
   
    ni = Len(x)
   
    Call base64decode(x, n(), ni)
   
    For c = 1 To ni
       
        decode64 = decode64 + Chr(n(c - 1))
   
    Next
   
End Function

Private Function BinToB64(B1 As Byte) As String
'----------------------------------------------------------------
'
'    in B1  : Base64 Binary (0-63)
'    return : Base64 Ascii Code
'----------------------------------------------------------------
Dim A1 As String

    If B1 <= 25 Then A1 = Chr(Asc("A") + B1)
    If B1 > 25 And B1 <= 51 Then A1 = Chr(Asc("a") + B1 - 26)
    If B1 > 51 And B1 <= 61 Then A1 = Chr(Asc("0") + B1 - 52)
    If B1 = 62 Then A1 = "+"
    If B1 = 63 Then A1 = "/"

    BinToB64 = A1
'Debug.Print B1; A1
End Function

Private Sub base64decode(B64str As String, Bstr() As Byte, BCnt As Long)
'----------------------------------------------------------------
' BASE64 DECODER [1996/04/27]
'    6bit ASCII -> 8bit Binary
'      in  B64str : Base64 ASCII Code Data
'      out Bstr   : 8bit Binary Data
'      out BCnt   : Bstr Data Length
'----------------------------------------------------------------

Dim Bmode As Integer
Dim ACnt As Long
Dim B1 As Byte
Dim RetVal As Integer
   
    ACnt = 0
    BCnt = 0
    Bmode = 0
   
    Do Until (Mid$(B64str, ACnt + 1, 1) = "=" Or Len(B64str) <= ACnt)
      If Fix(ACnt Mod 100) = 0 Then RetVal = DoEvents()
      B1 = B64ToBin(Mid$(B64str, ACnt + 1, 1))
      If B1 >= 0 And B1 <= 63 Then
        Select Case Bmode
            Case 0
              Bstr(BCnt) = B1 * 4                           'ãˆÊ6Bit
            Case 1
              Bstr(BCnt) = Bstr(BCnt) + (B1 \ 16)           '‰ºˆÊ2Bit
              BCnt = BCnt + 1                               '     +
              Bstr(BCnt) = (&HF And B1) * 16                'ãˆÊ4Bit
            Case 2
              Bstr(BCnt) = Bstr(BCnt) + (B1 \ 4)            '‰ºˆÊ4Bit
              BCnt = BCnt + 1                               '     +
              Bstr(BCnt) = (&H3 And B1) * 64                'ãˆÊ2Bit
            Case 3
              Bstr(BCnt) = Bstr(BCnt) + B1                  'ãˆÊ6Bit
              BCnt = BCnt + 1
        End Select
        Bmode = Bmode + 1
        If Bmode > 3 Then Bmode = 0
      End If
      ACnt = ACnt + 1
    Loop

End Sub


Private Function B64ToBin(A1 As String) As Byte

    Dim B1 As Byte

    If Len(A1) <> 1 Then
        B64ToBin = 255
        Exit Function
    End If
    B1 = 255
    If Asc(A1) >= Asc("A") And Asc(A1) <= Asc("Z") Then B1 = Asc(A1) - Asc("A") + 0
    If Asc(A1) >= Asc("a") And Asc(A1) <= Asc("z") Then B1 = Asc(A1) - Asc("a") + 26
    If Asc(A1) >= Asc("0") And Asc(A1) <= Asc("9") Then B1 = Asc(A1) - Asc("0") + 52
    If A1 = "+" Then B1 = 62
    If A1 = "/" Then B1 = 63

    B64ToBin = B1

End Function

Private Sub base64encode(Bstr() As Byte, Blen As Long, B64str As String)
'----------------------------------------------------------------
' BASE64 ENCODER [1996/04/27]
'    8bit Binary -> 6bit ASCII (A-Z,a-z,0-9,+,/,[=])
'      + Bstr   : 8bit Binary Data
'      + Blen   : Bstr Data Length
'      - B64str : Base64 ASCII Code Data
'----------------------------------------------------------------
Dim Bmode As Integer
Dim Cnt As Long
Dim B1 As Byte
Dim RetVal As Integer
Dim Str1 As String
Dim m As Integer
Dim Pos As Integer

    B64str = ""
    Cnt = 0
    Bmode = 0
       
    Do Until Blen <= Cnt
      If Fix(Cnt Mod 100) = 0 Then RetVal = DoEvents()
      B1 = Bstr(Cnt)
      Select Case Bmode
        Case 0
          B1 = (&HFC And B1) \ 4
        Case 1
          B1 = (&H3 And B1) * 16
          Cnt = Cnt + 1
          If Blen > Cnt Then
            B1 = B1 + (&HF0 And Bstr(Cnt)) \ 16
          End If
        Case 2
          B1 = (&HF And B1) * 4
          Cnt = Cnt + 1
          If Blen > Cnt Then
            B1 = B1 + (&HC0 And Bstr(Cnt)) \ 64 'ãˆÊ2Bit
          End If
        Case 3
          B1 = &H3F And B1                      '‰ºˆÊ6Bit
          Cnt = Cnt + 1
      End Select
     
      B64str = B64str & BinToB64(B1)

      Bmode = Bmode + 1
      If Bmode > 3 Then Bmode = 0
     
    Loop
   
    Select Case Bmode
      Case 0
        B64str = B64str
      Case 1, 2
        B64str = B64str & "=="
      Case 3
        B64str = B64str & "="
    End Select
   
    Str1 = ""
    m = 0
    Do Until Len(B64str) <= m * 76
        Pos = m * 76 + 1
        If Len(B64str) - Pos > 76 Then
            Str1 = Str1 & Mid$(B64str, Pos, 76) & vbCrLf
        Else
            Str1 = Str1 & Mid$(B64str, Pos, Len(B64str) - m * 76) & vbCrLf
        End If
        m = m + 1
    Loop
   
    B64str = Str1
    Debug.Print "Base64 Last Encode Mode = "; Bmode
   
End Sub

0
 
LVL 1

Author Comment

by:alweiner
ID: 1436559
Mark never sent me the code.  I'd like to assign the points to deighton
0
 
LVL 18

Accepted Solution

by:
deighton earned 50 total points
ID: 1436560
Here is my earlier solution re-posted as an answer.


      Public Function encode64(sX As String) As String

      'Encode to a string from a string

          Dim x() As Byte
          Dim iLen As Long, c As Long
          Dim sString As String
           
          iLen = Len(sX)
          ReDim x(iLen - 1)
           
          For c = 0 To iLen - 1
           
              x(c) = Asc(Mid(sX, c + 1, 1))
               
          Next
           
          Call base64encode(x, iLen, sString)
           
          encode64 = sString


      End Function

      Public Function decode64(x As String) As String

      'decode from a string to  a string

          Dim n() As Byte
          Dim ni As Long
          Dim sString As String
           
          ReDim n(Len(x) + 1)
           
          ni = Len(x)
           
          Call base64decode(x, n(), ni)
           
          For c = 1 To ni
               
              decode64 = decode64 + Chr(n(c - 1))
           
          Next
           
      End Function

      Private Function BinToB64(B1 As Byte) As String
      '----------------------------------------------------------------
      '
      '    in B1  : Base64 Binary (0-63)
      '    return : Base64 Ascii Code
      '----------------------------------------------------------------
      Dim A1 As String

          If B1 <= 25 Then A1 = Chr(Asc("A") + B1)
          If B1 > 25 And B1 <= 51 Then A1 = Chr(Asc("a") + B1 - 26)
          If B1 > 51 And B1 <= 61 Then A1 = Chr(Asc("0") + B1 - 52)
          If B1 = 62 Then A1 = "+"
          If B1 = 63 Then A1 = "/"

          BinToB64 = A1
      'Debug.Print B1; A1
      End Function

      Private Sub base64decode(B64str As String, Bstr() As Byte, BCnt As Long)
      '----------------------------------------------------------------
      ' BASE64 DECODER [1996/04/27]
      '    6bit ASCII -> 8bit Binary
      '      in  B64str : Base64 ASCII Code Data
      '      out Bstr   : 8bit Binary Data
      '      out BCnt   : Bstr Data Length
      '----------------------------------------------------------------

      Dim Bmode As Integer
      Dim ACnt As Long
      Dim B1 As Byte
      Dim RetVal As Integer
           
          ACnt = 0
          BCnt = 0
          Bmode = 0
           
          Do Until (Mid$(B64str, ACnt + 1, 1) = "=" Or Len(B64str) <= ACnt)
            If Fix(ACnt Mod 100) = 0 Then RetVal = DoEvents()
            B1 = B64ToBin(Mid$(B64str, ACnt + 1, 1))
            If B1 >= 0 And B1 <= 63 Then
              Select Case Bmode
                  Case 0
                    Bstr(BCnt) = B1 * 4                           'ãˆÊ6Bit
                  Case 1
                    Bstr(BCnt) = Bstr(BCnt) + (B1 \ 16)           '‰ºˆÊ2Bit
                    BCnt = BCnt + 1                               '     +
                    Bstr(BCnt) = (&HF And B1) * 16                'ãˆÊ4Bit
                  Case 2
                    Bstr(BCnt) = Bstr(BCnt) + (B1 \ 4)            '‰ºˆÊ4Bit
                    BCnt = BCnt + 1                               '     +
                    Bstr(BCnt) = (&H3 And B1) * 64                'ãˆÊ2Bit
                  Case 3
                    Bstr(BCnt) = Bstr(BCnt) + B1                  'ãˆÊ6Bit
                    BCnt = BCnt + 1
              End Select
              Bmode = Bmode + 1
              If Bmode > 3 Then Bmode = 0
            End If
            ACnt = ACnt + 1
          Loop

      End Sub


      Private Function B64ToBin(A1 As String) As Byte

          Dim B1 As Byte

          If Len(A1) <> 1 Then
              B64ToBin = 255
              Exit Function
          End If
          B1 = 255
          If Asc(A1) >= Asc("A") And Asc(A1) <= Asc("Z") Then B1 = Asc(A1) - Asc("A") + 0
          If Asc(A1) >= Asc("a") And Asc(A1) <= Asc("z") Then B1 = Asc(A1) - Asc("a") + 26
          If Asc(A1) >= Asc("0") And Asc(A1) <= Asc("9") Then B1 = Asc(A1) - Asc("0") + 52
          If A1 = "+" Then B1 = 62
          If A1 = "/" Then B1 = 63

          B64ToBin = B1

      End Function

      Private Sub base64encode(Bstr() As Byte, Blen As Long, B64str As String)
      '----------------------------------------------------------------
      ' BASE64 ENCODER [1996/04/27]
      '    8bit Binary -> 6bit ASCII (A-Z,a-z,0-9,+,/,[=])
      '      + Bstr   : 8bit Binary Data
      '      + Blen   : Bstr Data Length
      '      - B64str : Base64 ASCII Code Data
      '----------------------------------------------------------------
      Dim Bmode As Integer
      Dim Cnt As Long
      Dim B1 As Byte
      Dim RetVal As Integer
      Dim Str1 As String
      Dim m As Integer
      Dim Pos As Integer

          B64str = ""
          Cnt = 0
          Bmode = 0
               
          Do Until Blen <= Cnt
            If Fix(Cnt Mod 100) = 0 Then RetVal = DoEvents()
            B1 = Bstr(Cnt)
            Select Case Bmode
              Case 0
                B1 = (&HFC And B1) \ 4
              Case 1
                B1 = (&H3 And B1) * 16
                Cnt = Cnt + 1
                If Blen > Cnt Then
                  B1 = B1 + (&HF0 And Bstr(Cnt)) \ 16
                End If
              Case 2
                B1 = (&HF And B1) * 4
                Cnt = Cnt + 1
                If Blen > Cnt Then
                  B1 = B1 + (&HC0 And Bstr(Cnt)) \ 64 'ãˆÊ2Bit
                End If
              Case 3
                B1 = &H3F And B1                      '‰ºˆÊ6Bit
                Cnt = Cnt + 1
            End Select
             
            B64str = B64str & BinToB64(B1)

            Bmode = Bmode + 1
            If Bmode > 3 Then Bmode = 0
             
          Loop
           
          Select Case Bmode
            Case 0
              B64str = B64str
            Case 1, 2
              B64str = B64str & "=="
            Case 3
              B64str = B64str & "="
          End Select
           
          Str1 = ""
          m = 0
          Do Until Len(B64str) <= m * 76
              Pos = m * 76 + 1
              If Len(B64str) - Pos > 76 Then
                  Str1 = Str1 & Mid$(B64str, Pos, 76) & vbCrLf
              Else
                  Str1 = Str1 & Mid$(B64str, Pos, Len(B64str) - m * 76) & vbCrLf
              End If
              m = m + 1
          Loop
           
          B64str = Str1
          Debug.Print "Base64 Last Encode Mode = "; Bmode
           
      End Sub
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

24 Experts available now in Live!

Get 1:1 Help Now