Below is a class to encode strings or files in Base64. The data can be sent to the class as an ANSI string, a Unicode string, or a Byte Array. The sample program provided demonstrates the usage.
J.A. Coutts
Code:
Option Explicit
Private Const CBS As String = "CryptBinaryToString"
Private Const CSB As String = "CryptStringToBinary"
Private Const CRYPT_STRING_BASE64 As Long = 1
Private sBase64Buf As String
Private m_bData() As Byte
Private Declare Function CryptBinaryToString Lib "Crypt32.dll" Alias "CryptBinaryToStringW" (ByRef pbBinary As Byte, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, ByRef pcchString As Long) As Long
Private Declare Function CryptStringToBinary Lib "Crypt32.dll" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
'================================
'EVENTS
'================================
Public Event Error(ByVal Number As Long, Description As String, ByVal Source As String)
Public Property Get bBuffer() As Byte()
bBuffer = m_bData
End Property
Public Property Let bBuffer(bNewValue() As Byte)
m_bData = bNewValue
End Property
Public Property Get Base64Buf() As String
Base64Buf = sBase64Buf
End Property
Public Property Let Base64Buf(sNewValue As String)
sBase64Buf = sNewValue
End Property
Public Sub Base64Decode()
Const Routine As String = "Base64.Base64Decode"
Const CRYPT_STRING_BASE64 As Long = 1
Const CRYPT_STRING_NOCRLF As Long = &H40000000
Dim bTmp() As Byte
Dim lLen As Long
Dim dwActualUsed As Long
'Get output buffer length
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then
RaiseEvent Error(Err.LastDllError, CSB, Routine)
GoTo ReleaseHandles
End If
'Convert Base64 to binary.
ReDim bTmp(lLen - 1)
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then
RaiseEvent Error(Err.LastDllError, CSB, Routine)
GoTo ReleaseHandles
Else
m_bData = bTmp
End If
ReleaseHandles:
End Sub
Public Sub Base64Encode()
Const Routine As String = "Base64.Base64Encode"
Dim lLen As Long
'Determine Base64 output String length required.
If CryptBinaryToString(m_bData(0), UBound(m_bData) + 1, CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen) = 0 Then
RaiseEvent Error(Err.LastDllError, CBS, Routine)
GoTo ReleaseHandles
End If
'Convert binary to Base64.
sBase64Buf = String$(lLen - 1, Chr$(0))
If CryptBinaryToString(m_bData(0), UBound(m_bData) + 1, CRYPT_STRING_BASE64, StrPtr(sBase64Buf), lLen) = 0 Then
RaiseEvent Error(Err.LastDllError, CBS, Routine)
GoTo ReleaseHandles
End If
ReleaseHandles:
End Sub
Public Property Get sBuffer() As String
sBuffer = ByteToStr(m_bData)
End Property
Public Property Let sBuffer(sNewValue As String)
Dim bTmp() As Byte
bTmp = StrToByte(sNewValue)
m_bData = bTmp
End Property
Public Property Get uBuffer() As String
uBuffer = ByteToUni(m_bData)
End Property
Public Property Let uBuffer(sNewValue As String)
Dim bTmp() As Byte
bTmp = sNewValue
uBuffer = bTmp
End Property
These functions were located in a cryptography class. I had need of the Base64 functions without the rest of the class, so I created a separate class. StrConv causes problems on systems set for non-latin character sets, so I don't use them anymore.
StrConv causes problems on systems set for non-latin character sets, so I don't use them anymore.
Not sure that's completely true. Improper usage is likely the reason. For example, you cannot convert say Chinese characters to ANSI, or vice versa, with StrConv and expect success.
Just a note: I think if people will consider using your class, they'd prefer to have the class self-contained, not needing to also include a bas module for a function or two when any needed function could be included in the class itself.
Last edited by LaVolpe; Jul 12th, 2017 at 07:26 AM.
Insomnia is just a byproduct of, "It can't be done"
These functions were located in a cryptography class. I had need of the Base64 functions without the rest of the class, so I created a separate class. StrConv causes problems on systems set for non-latin character sets, so I don't use them anymore.
J.A. Coutts
Not so much a problem except that it uses the system default code page / LCID if you don't specify.
If you want it hard coded to a specific LocaleID you have to pass in the 3rd parameter to StrConv.
Not so much a problem except that it uses the system default code page / LCID if you don't specify.
If you want it hard coded to a specific LocaleID you have to pass in the 3rd parameter to StrConv.
Wouldn't think, in this case, that would be an issue since conversion is being done to/from byte arrays and Base64 (ANSI). In other scenarios, misuse is likely the reason, not the function itself.
Insomnia is just a byproduct of, "It can't be done"
Okay to summaries it.
Carefully study ByteToStr and StrToByte...
... and delete them!
They are great for headaches, or good for the 'english only version' but yeah :
That's how it's not gonna work.
For char between 0..127 the results may be fine but for rests there'll be all the time the one or other 'off's', char artefacts, trouble chars or other oddities. That depend from language the program is ran.
Use StrConv!
That'll be the only reliable way.
Code:
Public Property Get sBuffer() As String
' sBuffer = StrConv(m_bData, vbUnicode)
sBuffer = AToU(m_bData)
End Property
Public Property Let sBuffer(sNewValue As String)
m_bData = UToA(sNewValue)
End Property
Public Function UToA(unicode)
UToA = StrConv(unicode, vbFromUnicode, LCID)
End Function
Public Function AToU(unicode)
AToU = StrConv(unicode, vbUnicode, LCID)
End Function
Well you can just delete the optional LCID parameter but I recommended to keep it and add this into some module:
Code:
Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Public Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Sub LCID_init()
Dim sys_LCID
sys_LCID = GetSystemDefaultLCID()
Dim usr_LCID
usr_LCID = GetUserDefaultLCID()
If sys_LCID <> usr_LCID Then
Stop
' Well that case is a little special so maybe
' ask user how to proceed
' well mostly it seems the best to use SystemDefaultLCID
LCID = sys_LCID
Else
LCID = usr_LCID
End If
End Sub
Public Property Get LCID() As Variant
' ensure that mLocaleID is initialised
Debug.Assert mLocaleID <> 0
LCID = mLocaleID
End Property
Public Property Let LCID(ByVal vNewValue As Variant)
Debug.Assert vNewValue <> 0 'invalid number
mLocaleID = vNewValue
End Property
LCID_init()
Maybe also move that AToU and UToA into this module for better code organisation ( and for the sake of 'Locality' ).
Last edited by cw2k; Feb 16th, 2018 at 05:44 PM.
Reason: So now the call LCID_init() is there also
There are major problems using StrConv on systems that are set to use non-latin character sets. You will find lots of evidence on this site to verify that. I personally ran into problems with a handful of characters above 127, that the operating system changes in the background without your knowledge. Once it was pointed out to me that StrConv and non-latin character sets don't get along, I no longer use it.
I am sure that string to byte convertion not needed here. We can make a string as big as to hold data and copy data there. Also we can use string ptr to place data. We have to remove all ByRef and place ByVal, so we pass only pointers as return from StrPtr(). We can pass array to, just passing the right pointer (also by value).
Private Declare Function CryptStringToBinary Lib "Crypt32.dll" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByVal pcbBinary As Long, ByVal pdwSkip As Long, ByVal pdwFlags As Long) As Long
Converting Unicode characters to byte array is dead simple.
Code:
Public Function UniToByte(strInput As String) As Byte()
UniToByte = strInput
End Function
Public Function ByteToUni(bArray() As Byte) As String
ByteToUni = bArray
End Function
I rewrote this into easier-to-reuse code that can be copy/pasted into a module
Code:
Private Declare Function CryptBinaryToString Lib "Crypt32.dll" Alias "CryptBinaryToStringW" (ByRef pbBinary As Byte, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As Long, ByRef pcchString As Long) As Long
Private Declare Function CryptStringToBinary Lib "Crypt32.dll" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
Public Function Base64Decode(sBase64Buf As String) As String
Const CRYPT_STRING_BASE64 As Long = 1
Dim bTmp() As Byte, lLen As Long, dwActualUsed As Long
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then Exit Function 'Get output buffer length
ReDim bTmp(lLen - 1)
If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then Exit Function 'Convert Base64 to binary.
Base64Decode = StrConv(bTmp, vbUnicode)
End Function
Public Function Base64Encode(Text As String) As String
Const CRYPT_STRING_BASE64 As Long = 1
Dim lLen As Long, m_bData() As Byte, sBase64Buf As String
m_bData = StrConv(Text, vbFromUnicode)
If CryptBinaryToString(m_bData(0), UBound(m_bData) + 1, CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen) = 0 Then Exit Function 'Determine Base64 output String length required.
sBase64Buf = String$(lLen - 1, Chr$(0)) 'Convert binary to Base64.
If CryptBinaryToString(m_bData(0), UBound(m_bData) + 1, CRYPT_STRING_BASE64, StrPtr(sBase64Buf), lLen) = 0 Then Exit Function
Base64Encode = sBase64Buf
End Function