Re: Base64 encoding/decoding in VB6
From: Ulrich Korndoerfer (ulrich_wants_nospam_at_prosource.de)
Date: 10/21/04
- Next message: sympatico: "Re: Byte?"
- Previous message: Jeff Johnson [MVP: VB]: "Re: Base64 encoding/decoding in VB6"
- In reply to: Dwight: "Base64 encoding/decoding in VB6"
- Next in thread: Mike D Sutton: "Re: Base64 encoding/decoding in VB6"
- Messages sorted by: [ date ] [ thread ]
Date: Thu, 21 Oct 2004 15:46:06 +0200
Hi,
Dwight wrote:
>
> Hi
>
> Does anyone know how I can encode binary data to produce a character string
> using VB6.
Appended is a class CBase64 doing Base64 en/decoding
'Class CBase64
Private Const mcClassName As String = "CBase64"
'******************************************************************************
'* API declarations
'******************************************************************************
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" _
(ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Private Declare Sub CopyMem4 Lib "msvbvm60.dll" Alias "GetMem4" _
(ByRef FromAddr As Any, _
ByRef ToAddr As Any)
'******************************************************************************
'* Private consts, member vars and types
'******************************************************************************
Private Const mcBASE64_CHARSET As String =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Private Const mcBASE64_PADDINGBYTE As Byte = 61 'Chr$(61) = "="
Private Const mcSHIFT6 As Long = 64
Private Const mcSHIFT12 As Long = mcSHIFT6 * mcSHIFT6
Private Const mcSHIFT18 As Long = mcSHIFT12 * mcSHIFT6
'Static arrays wrapped in an UDT are used for performance reasons
'(adressing of array elements is faster).
Private Type TEncodeTable
Enc(0 To 63) As Byte
End Type
Private Type TDecodeTable
Dec(0 To 255) As Long
End Type
Private Type TLongByte
B(0 To 3) As Byte
End Type
Private mEncodeTable As TEncodeTable
Private mDecodeTable As TDecodeTable
'******************************************************************************
'* Public methods
'******************************************************************************
'Encode encodes the byte array Source() to a string using the BASE64
encoding.
'Input param Source() is not altered
'Restrictions to the input array:
'- Source must be an initialized, non zombie, one dimensional, zero
based array.
' Source may be a static or dynamic array
'Encode: 8 Bit triplet S(i+1),S(i+1),S(i+2) -> 6 Bit quartet
O(j+0),O(j+1),O(j+2),O(j+3)
' S(i+0) S(i+1) S(i+2)
' | | | | | |
' | +---+ | +---+ | |
' H6| L2| H4| L4| H2| L6|
' | | | | | |
' O(j+0) O(j+1) O(j+2) O(j+3)
' S(i+0) S(i+1) 0
' | | | | |
' | +---+ | +---+ |
' H6| L2| H4| L4| 02|
' | | | | |
' O(j+0) O(j+1) O(j+2) 0
' S(i+0) 0 0
' | | |
' | +---+ |
' H6| L2| 04|
' | | |
' O(j+0) O(j+1) 0 0
Public Function Encode(ByRef Source() As Byte) As String
Const cMETHODNAME As String = "Encode"
Dim Src() As Byte, SrcTop As Long, Out() As Byte, OutTop As Long, Pad As
Long
Dim AccuL As Long, AccuB As TLongByte
Dim i As Long, j As Long
'Prepare helper arrays
Src = Source: i = UBound(Source)
SrcTop = (i \ 3&) * 3& + 2& 'results to n*3 + 2, where n=0,1,2,...
Pad = SrcTop - i: If Pad > 0& Then ReDim Preserve Src(0& To SrcTop)
OutTop = (i \ 3&) * 4& + 3& 'results to n*4 + 3, where n is from above
ReDim Out(0& To OutTop)
'Encode Src() to Out()
'AccuL = | B(3) | B(2) | B(1) | B(0) |
'AccuL = | 0 | Src(i+0) | Src(i+1) | Src(i+2) |
For i = 0& To SrcTop Step 3&
With AccuB
.B(0) = Src(i + 2&)
.B(1) = Src(i + 1&)
.B(2) = Src(i)
End With
CopyMem4 AccuB, AccuL
With mEncodeTable
Out(j) = .Enc((AccuL \ mcSHIFT18)) 'H6[ Src(i+0) ]
Out(j + 1&) = .Enc((AccuL \ mcSHIFT12) And 63&) 'L2[ Src(i+0) ] |
H4[ Src(i+1) ]
Out(j + 2&) = .Enc((AccuL \ mcSHIFT6) And 63&) 'L4[ Src(i+1) ] |
H2[ Src(i+2) ]
Out(j + 3&) = .Enc(AccuL And 63&) 'L6[ Src(i+2) ]
End With
j = j + 4&
Next i
'Do padding
If Pad = 2& Then Out(OutTop - 1&) = mcBASE64_PADDINGBYTE
If Pad > 0& Then Out(OutTop) = mcBASE64_PADDINGBYTE
'Return encoded
Encode = StrConv(Out, vbUnicode)
End Function
'Decode decodes a BASE64 encoded string to an one dimensional, zero
based byte array.
'Input param Source is not altered.
'Checks done on the to be decoded input string:
'- length must be a multiple of 4, not zero
'- last two chars must be a legal combination of padding chars
'- illegal characters in the rest of the string. Illegal is any
character, which is not in
' the BASE64 code table. This excludes the padding chararacter too!
'Decode: 6 Bit quartet S(i+0),S(i+1),S(i+2),S(i+3) -> 8 Bit triplet
O(j+0),O(j+1),O(j+2)
' S(i+0) S(i+1) S(i+2) S(i+3)
' | | | | | |
' L6| H2| L4| H4| L2| L6|
' | +---+ | +---+ | |
' | | | | | |
' O(j+0) O(j+1) O(j+2)
' S(i+0) S(i+1) S(i+2) 0
' | | | | |
' L6| H2| L4| H4| 02|
' | +---+ | +---+ |
' | | | | |
' O(j+0) O(j+1) 0
' S(i+0) S(i+1) 0 0
' | | |
' L6| H2| 04|
' | +---+ |
' | | |
' O(j+0) 0 0
Public Function Decode(ByRef Source As String) As Byte()
Const cMETHODNAME As String = "Decode"
Dim Src() As Byte, SrcTop As Long, Out() As Byte, Pad As Long
Dim AccuL As Long, AccuB As TLongByte
Dim i As Long, j As Long
'Check length
i = Len(Source)
If i = 0 Or (i Mod 4) <> 0 Then ErrRaise cMETHODNAME, "Invalid length"
'Prepare helper arrays
Src = StrConv(Source, vbFromUnicode)
SrcTop = i - 1
ReDim Out(0& To ((i) \ 4&) * 3& - 1&)
'Check padding
If Src(SrcTop) = mcBASE64_PADDINGBYTE Then
Pad = 1&: Src(SrcTop) = mEncodeTable.Enc(0)
End If
If Src(SrcTop - 1&) = mcBASE64_PADDINGBYTE Then
If Pad = 0 Then
ErrRaise cMETHODNAME, "Invalid padding"
Else
Pad = 2&: Src(SrcTop - 1&) = mEncodeTable.Enc(0)
End If
End If
'Decode Src() to Out(). Check on invalid characters is included in the
decoding algorithm.
'D() = Dec(Src()), having its low *6* bits carrying information, others
are 0
'H4[D()] reads: the 4 high bits of D()'s low 6 bits
'AccuL = | 0 | H6[D(i+0)] H2[D(i+1)] | L4[D(i+1)] H4[D(i+2)] |
L2[D(i+2)] H6[D(i+3)] |
'AccuL = | B(3) | B(2) | B(1) |
B(0) |
For i = 0& To SrcTop Step 4&
With mDecodeTable
AccuL = (.Dec(Src(i)) * mcSHIFT18) Or _
(.Dec(Src(i + 1&)) * mcSHIFT12) Or _
(.Dec(Src(i + 2&)) * mcSHIFT6) Or _
.Dec(Src(i + 3&))
End With
CopyMem4 AccuL, AccuB
With AccuB
If .B(3) = 0 Then
Out(j + 2&) = .B(0)
Out(j + 1&) = .B(1)
Out(j) = .B(2)
Else
ErrRaise cMETHODNAME, "Invalid character found"
End If
End With
j = j + 3&
Next i
'Adjust decoded array length according to padding
If Pad > 0 Then ReDim Preserve Out(0 To UBound(Out) - Pad)
Decode = Out
End Function
'******************************************************************************
'* Private helpers
'******************************************************************************
Private Sub ErrRaise(ByVal MethodName As String, Optional ByVal
Description As String)
Err.Raise 5, mcClassName & "." & MethodName, Description
End Sub
'******************************************************************************
'* Class de/construction
'******************************************************************************
Private Sub Class_Initialize()
Dim i As Long, Enc() As Byte
Enc = StrConv(mcBASE64_CHARSET, vbFromUnicode)
RtlMoveMemory mEncodeTable.Enc(0), Enc(0), 64
With mDecodeTable
For i = 0 To 255: .Dec(i) = -1: Next
For i = 0 To 63: .Dec(Enc(i)) = i: Next
.Dec(mcBASE64_PADDINGBYTE) = -2
End With
End Sub
-- Ulrich Korndoerfer VB tips, helpers, solutions -> http://www.proSource.de/Downloads/
- Next message: sympatico: "Re: Byte?"
- Previous message: Jeff Johnson [MVP: VB]: "Re: Base64 encoding/decoding in VB6"
- In reply to: Dwight: "Base64 encoding/decoding in VB6"
- Next in thread: Mike D Sutton: "Re: Base64 encoding/decoding in VB6"
- Messages sorted by: [ date ] [ thread ]
Relevant Pages
|
