2

I am trying to read in a JPG file and convert the file to a base64 encoded string that can be used as an embedded jpeg on a web page. I found two functions on the web for base64 encoding/decoding in VBA that appear to be well-accepted. The encode/decode process yields my original binary string, so the functions appear to be at least somewhat correct. However the base64 string I am getting is no where near what I get when I use an online tool to convert my image to base64.

The base64 string should start: "/9j/4AAQSkZJRgABAQEAUgBSAAD". Instead it is starting with: "Pz8/Pz9BYT8/AD8/Pz8/Pz8/Pz8/Pz8/Pz8". I'm lost as to why I'm not getting the former result and why I'm getting the latter. Am I doing something wrong in my reading of the binary file?

Here is my code:

Sub TestBase64()
    Dim bytes, b64
    With CreateObject("ADODB.Stream")
    .Open
    .Type = ADODB.adTypeBinary
    .LoadFromFile "c:\temp\TestPic.jpg"
    bytes = .Read
    .Close
    End With
    Debug.Print bytes
    b64 = Base64Encode(bytes)
    Debug.Print vbCrLf + vbCrLf
    Debug.Print b64
    Debug.Print vbCrLf + vbCrLf
    Debug.Print Base64Decode(CStr(b64))        
End Sub

' Decodes a base-64 encoded string (BSTR type).
' 1999 - 2004 Antonin Foller, http://www.motobit.com
' 1.01 - solves problem with Access And 'Compare Database' (InStr)
Function Base64Decode(ByVal base64String)
  'rfc1521
  '1999 Antonin Foller, Motobit Software, http://Motobit.cz
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim dataLength, sOut, groupBegin

  'remove white spaces, If any
  base64String = Replace(base64String, vbCrLf, "")
  base64String = Replace(base64String, vbTab, "")
  base64String = Replace(base64String, " ", "")

  'The source must consists from groups with Len of 4 chars
  dataLength = Len(base64String)
  If dataLength Mod 4 <> 0 Then
    Err.Raise 1, "Base64Decode", "Bad Base64 string."
    Exit Function
  End If


  ' Now decode each group:
  For groupBegin = 1 To dataLength Step 4
    Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
    ' Each data group encodes up To 3 actual bytes.
    numDataBytes = 3
    nGroup = 0

    For CharCounter = 0 To 3
      ' Convert each character into 6 bits of data, And add it To
      ' an integer For temporary storage.  If a character is a '=', there
      ' is one fewer data byte.  (There can only be a maximum of 2 '=' In
      ' the whole string.)

      thisChar = Mid(base64String, groupBegin + CharCounter, 1)

      If thisChar = "=" Then
        numDataBytes = numDataBytes - 1
        thisData = 0
      Else
        thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
      End If
      If thisData = -1 Then
        Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
        Exit Function
      End If

      nGroup = 64 * nGroup + thisData
    Next

    'Hex splits the long To 6 groups with 4 bits
    nGroup = Hex(nGroup)

    'Add leading zeros
    nGroup = String(6 - Len(nGroup), "0") & nGroup

    'Convert the 3 byte hex integer (6 chars) To 3 characters
    pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
      Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
      Chr(CByte("&H" & Mid(nGroup, 5, 2)))

    'add numDataBytes characters To out string
    sOut = sOut & Left(pOut, numDataBytes)
  Next

  Base64Decode = sOut
End Function

Function Base64Encode(inData)
  'rfc1521
  '2001 Antonin Foller, Motobit Software, http://Motobit.cz
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim cOut, sOut, i

  'For each group of 3 bytes
  For i = 1 To Len(inData) Step 3
    Dim nGroup, pOut, sGroup

    'Create one long from this 3 bytes.
    nGroup = &H10000 * Asc(Mid(inData, i, 1)) + _
      &H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1))

    'Oct splits the long To 8 groups with 3 bits
    nGroup = Oct(nGroup)

    'Add leading zeros
    nGroup = String(8 - Len(nGroup), "0") & nGroup

    'Convert To base64
    pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
      Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
      Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
      Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)

    'Add the part To OutPut string
    sOut = sOut + pOut

    'Add a new line For Each 76 chars In dest (76*3/4 = 57)
    'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
  Next
  Select Case Len(inData) Mod 3
    Case 1: '8 bit final
      sOut = Left(sOut, Len(sOut) - 2) + "=="
    Case 2: '16 bit final
      sOut = Left(sOut, Len(sOut) - 1) + "="
  End Select
  Base64Encode = sOut
End Function

Function MyASC(OneChar)
  If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function

1 Answer 1

4

That's some lengthy way to encode. I prefer this:

You Need to add reference to Microsoft XML, v6.0 (or v3.0)

Sub TestBase64()
    Dim bytes, b64
    With CreateObject("ADODB.Stream")
    .Open
    .Type = ADODB.adTypeBinary
    .LoadFromFile "c:\temp\TestPic.jpeg"
    bytes = .Read
    .Close
    End With
    Debug.Print bytes
    b64 = EncodeBase64(bytes)
    Debug.Print vbCrLf + vbCrLf
    Debug.Print Left(b64, 100)
'    Debug.Print vbCrLf + vbCrLf
'    Debug.Print Base64Decode(CStr(b64))
End Sub

Private Function EncodeBase64(bytes) As String

    Dim objXML                      As MSXML2.DOMDocument
    Dim objNode                     As MSXML2.IXMLDOMElement


    Set objXML = New MSXML2.DOMDocument
    Set objNode = objXML.createElement("b64")

    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = bytes
    EncodeBase64 = objNode.Text

    Set objNode = Nothing
    Set objXML = Nothing
End Function

Output (first few characters): /9j/4AAQSkZJRgABAQEAYABgAAD

Sign up to request clarification or add additional context in comments.

1 Comment

awesome, that's a much cleaner way to do base64!

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.