|
-
Apr 14th, 2018, 01:08 PM
#17
Re: VB - Fast Base64 Encoding and Decoding
I do some serius job here;
Advanced Decoder;
Encoder and Decoder works nice. Spaces and Cr and Lf dropped at decoding not with replace(). If we place a non proper char in a string for decoding, decoder stop decoding and decide if it is a proper encoding string or raise an error.
Also I found the problem with Encoder, when we have a Cr code and then place = (61). The solution was an extra Dim Presereve.
Code:
Option Explicit
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Const clOneMask = 16515072 '000000 111111 111111 111111
Private Const clTwoMask = 258048 '111111 000000 111111 111111
Private Const clThreeMask = 4032 '111111 111111 000000 111111
Private Const clFourMask = 63 '111111 111111 111111 000000
Private Const clHighMask = 16711680 '11111111 00000000 00000000
Private Const clMidMask = 65280 '00000000 11111111 00000000
Private Const clLowMask = 255 '00000000 00000000 11111111
Private Const cl2Exp18 = 262144 '2 to the 18th power
Private Const cl2Exp12 = 4096 '2 to the 12th
Private Const cl2Exp6 = 64 '2 to the 6th
Private Const cl2Exp8 = 256 '2 to the 8th
Private Const cl2Exp16 = 65536 '2 to the 16th
' Refubrish By GeorgeKar
Public Function Encode64(sString As String) As String
Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, lOutSize As Long
For lTemp = 0 To 63 'Fill the translation table.
Select Case lTemp
Case 0 To 25
bTrans(lTemp) = 65 + lTemp 'A - Z
Case 26 To 51
bTrans(lTemp) = 71 + lTemp 'a - z
Case 52 To 61
bTrans(lTemp) = lTemp - 4 '1 - 0
Case 62
bTrans(lTemp) = 43 'Chr(43) = "+"
Case 63
bTrans(lTemp) = 47 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 255 'Fill the 2^8 and 2^16 lookup tables.
lPowers8(lTemp) = lTemp * cl2Exp8
lPowers16(lTemp) = lTemp * cl2Exp16
Next lTemp
iPad = Len(sString) Mod 3 'See if the length is divisible by 3
ReDim bIn(0 To Len(sString) * 2 - 1 + iPad)
CopyMemory bIn(0), ByVal StrPtr(sString), Len(sString) * 2
lLen = ((UBound(bIn) + 1) \ 3) * 4 'Length of resulting string.
' set to 60 wchar for each line break
lTemp = lLen \ 60 'Added space for vbCrLfs.
lOutSize = ((lTemp * 2) + lLen) - 1 'Calculate the size of the output buffer.
ReDim bOut(lOutSize) 'Make the output buffer.
lLen = 0 'Reusing this one, so reset it.
For lChar = LBound(bIn) To UBound(bIn) Step 3
lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2) 'Combine the 3 bytes
lTemp = lTrip And clOneMask 'Mask for the first 6 bits
bOut(lPos) = bTrans(lTemp \ cl2Exp18) 'Shift it down to the low 6 bits and get the value
lTemp = lTrip And clTwoMask 'Mask for the second set.
bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12) 'Shift it down and translate.
lTemp = lTrip And clThreeMask 'Mask for the third set.
bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6) 'Shift it down and translate.
bOut(lPos + 3) = bTrans(lTrip And clFourMask) 'Mask for the low set.
If lLen = 60 Then 'Ready for a newline
bOut(lPos + 4) = 13 'Chr(13) = vbCr
bOut(lPos + 5) = 10 'Chr(10) = vbLf
lLen = 0 'Reset the counter
lPos = lPos + 6
Else
lLen = lLen + 4
lPos = lPos + 4
End If
Next lChar
ReDim Preserve bOut(lPos - 1)
lOutSize = lPos - 1
If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.
If iPad = 1 Then 'Add the padding chars if any.
bOut(lOutSize) = 61 'Chr(61) = "="
ElseIf iPad = 2 Then
bOut(lOutSize) = 61
bOut(lOutSize - 1) = 61
End If
Encode64 = StrConv(bOut, vbUnicode) 'Convert back to a string and return it.
End Function
Public Function Decode64(sString As String) As String
Dim ok As Boolean
ok = True
If Len(sString) = 0 Then Exit Function
Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
Dim lTemp As Long
For lTemp = 0 To 255 'Fill the translation table.
Select Case lTemp
Case 65 To 90
bTrans(lTemp) = lTemp - 65 'A - Z
Case 97 To 122
bTrans(lTemp) = lTemp - 71 'a - z
Case 48 To 57
bTrans(lTemp) = lTemp + 4 '1 - 0
Case 43
bTrans(lTemp) = 62 'Chr(43) = "+"
Case 47
bTrans(lTemp) = 63 'Chr(47) = "/"
End Select
Next lTemp
For lTemp = 0 To 63 'Fill the 2^6, 2^12, and 2^18 lookup tables.
lPowers6(lTemp) = lTemp * cl2Exp6
lPowers12(lTemp) = lTemp * cl2Exp12
lPowers18(lTemp) = lTemp * cl2Exp18
Next lTemp
bIn = StrConv(sString, vbFromUnicode) 'Load the input byte array.
ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1 + 4) 'Prepare the output buffer.
lChar = 0
Dim lChar2 As Long, lChar3 As Long, lchar1 As Long
Dim ubnd As Long
ubnd = UBound(bIn)
lChar3 = lChar - 1
Do
lChar = lChar3 + 1
If lChar >= ubnd Then lChar3 = lChar: GoTo finish
ok = False
Do
Select Case bIn(lChar)
Case 65 To 90, 97 To 122, 48 To 57, 43, 47
Exit Do
Case 61
lChar3 = lChar: GoTo finish
Exit Do
Case 10, 13, 32
lChar = lChar + 1
If lChar > ubnd Then lChar3 = lChar: GoTo finish
Case Else
lChar = lChar + 1
lChar3 = lChar: GoTo finish
GoTo finish
End Select
Loop
lchar1 = lChar + 1
If lchar1 > ubnd Then lChar3 = lchar1: GoTo finish
Do
Select Case bIn(lchar1)
Case 65 To 90, 97 To 122, 48 To 57, 43, 47
Exit Do
Case 61
lChar3 = lchar1: GoTo finish
Case 10, 13, 32
lchar1 = lchar1 + 1
If lchar1 > ubnd Then lChar3 = lchar1: GoTo finish
Case Else
lchar1 = lchar1 + 1
lChar3 = lchar1: GoTo finish
End Select
Loop
lChar2 = lchar1 + 1
If lChar2 > ubnd Then lChar3 = lChar2: GoTo finish
Do
Select Case bIn(lChar2)
Case 65 To 90, 97 To 122, 48 To 57, 43, 47
Exit Do
Case 61
lChar3 = lChar2: GoTo finish
Exit Do
Case 10, 13, 32
lChar2 = lChar2 + 1
If lChar2 > ubnd Then lChar3 = lChar2: GoTo finish
Case Else
lChar2 = lChar2 + 1
lChar3 = lChar2: GoTo finish
End Select
Loop
lChar3 = lChar2 + 1
If lChar3 > ubnd Then GoTo finish
Do
Select Case bIn(lChar3)
Case 65 To 90, 97 To 122, 48 To 57, 43, 47
Exit Do
Case 61
GoTo finish
Case 10, 13, 32
lChar2 = lChar2 + 1
If lChar2 > ubnd Then lChar3 = lChar2: GoTo finish
Case Else
lChar3 = lChar3 + 1
If lChar3 > ubnd Then GoTo finish
GoTo finish
End Select
Loop
ok = True
lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lchar1))) + _
lPowers6(bTrans(bIn(lChar2))) + bTrans(bIn(lChar3)) 'Rebuild the bits.
lTemp = lQuad And clHighMask 'Mask for the first byte
bOut(lPos) = lTemp \ cl2Exp16 'Shift it down
lTemp = lQuad And clMidMask 'Mask for the second byte
bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down
bOut(lPos + 2) = lQuad And clLowMask 'Mask for the third byte
lPos = lPos + 3
Loop
finish:
If Not ok Then
iPad = 0
Dim offset As Long
Do While lChar3 + iPad + offset < ubnd
Select Case bIn(lChar3 + iPad + offset)
Case 10, 13, 32
offset = offset + 1
Case 61
iPad = iPad + 1
Case Else
If (lChar3 + iPad + offset + 3) Mod 4 <> 0 Then GoTo error1
bIn(lChar3 + iPad + offset) = 0
bIn(lChar3 + iPad + offset + 1) = 0
bIn(lChar3 + iPad + offset + 2) = 0
bIn(lChar3 + iPad + offset + 3) = 0
'lChar3 = lChar + 1
Exit Do
End Select
Loop
lChar3 = lChar3 + offset
If iPad > 2 Then GoTo error1
If iPad = 0 Then
If (lPos + 2) Mod 3 + 1 <> 3 Then
GoTo error1
End If
Else
If (lPos + 3 - iPad) Mod 3 + iPad <> 3 Then
GoTo error1
End If
End If
ok = True
If lChar3 > ubnd Then GoTo cont1
If lChar = lChar3 Then
lChar = lChar + 1: lChar3 = lChar3 + 1
lchar1 = lChar3
lChar2 = lChar3
End If
If lchar1 = lChar3 Then
lchar1 = lchar1 + 1: lChar3 = lChar3 + 1
lChar2 = lChar3
End If
If lChar2 = lChar3 Then
lChar2 = lChar2 + 1: lChar3 = lChar3 + 1
End If
If lChar3 <= ubnd Then
lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lchar1))) + _
lPowers6(bTrans(bIn(lChar2))) + bTrans(bIn(lChar3)) 'Rebuild the bits.
lTemp = lQuad And clHighMask 'Mask for the first byte
bOut(lPos) = lTemp \ cl2Exp16 'Shift it down
lTemp = lQuad And clMidMask 'Mask for the second byte
bOut(lPos + 1) = lTemp \ cl2Exp8 'Shift it down
bOut(lPos + 2) = lQuad And clLowMask
End If
lPos = lPos + 2 - iPad
GoTo cont1
error1:
Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
Exit Function
End If
cont1:
sOut = String$((lPos + 1) \ 2, Chr(0))
CopyMemory ByVal StrPtr(sOut), bOut(0), Len(sOut) * 2
Decode64 = sOut
End Function
Last edited by georgekar; Apr 15th, 2018 at 06:18 AM.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote