Attribute VB_Name = "Module1"
Option Explicit
'*/-------------------------------------------------------------
'*/函 數 名:B64E
'*/功    能:Base64 編碼函數
'*/返 回 值:字符
'*/參    數:
'*/建立日期:2004-12-24
'*/修改日期:
'*/調用方法:
'*/      Dim arrstr() As Byte
'*/      arrstr = StrConv(StrConv(Text1.Text, vbFromUnicode), vbUnicode)         ' 先轉化成ASC碼再轉化成UNICODE碼
'*/      Text2.Text = B64E(arrstr)
'*/-------------------------------------------------------------
Function B64E(inData() As Byte) As String
    On Error Resume Next
    Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim UB As Long, lB As Long                 '數組的上限和下限
    Dim sOut, cOut, i
    Dim nGroup   As Long
    Dim pOut, sGroup
    UB = UBound(inData)
    Dim Second As Byte
    Dim Thrid As Byte
    lB = LBound(inData)
    If Err.Number <> 0 Then
        B64E = ""
        Exit Function
    End If
    For i = lB To UB Step 3
        If i + 1 > UB Then
            Second = 0
            Thrid = 0
        ElseIf i + 2 > UB Then
            Second = inData(i + 1)
            Thrid = 0
        Else
            Second = inData(i + 1)
            Thrid = inData(i + 2)
        End If
        nGroup = &H10000 * inData(i) + &H100 * Second + Thrid
        sGroup = Oct(nGroup)
        sGroup = String(8 - Len(sGroup), "0") + sGroup
        pOut = Mid(Base64, CLng("&o" + Mid(sGroup, 1, 2)) + 1, 1) + Mid(Base64, CLng("&o" + Mid(sGroup, 3, 2)) + 1, 1) + Mid(Base64, CLng("&o" + Mid(sGroup, 5, 2)) + 1, 1) + Mid(Base64, CLng("&o" + Mid(sGroup, 7, 2)) + 1, 1)
        sOut = sOut + pOut
        If (i + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
        nGroup = 0
    Next i
    Select Case (UB - lB + 1) Mod 3
    Case 1
        sOut = Left(sOut, Len(sOut) - 2) + "=="
    Case 2
        sOut = Left(sOut, Len(sOut) - 1) + "="
    End Select
    B64E = sOut
End Function

'*/-------------------------------------------------------------
'*/函 數 名:B64U
'*/功    能:Base64解碼函數
'*/返 回 值:字符
'*/參    數:
'*/建立日期:2004-12-24
'*/修改日期:
'*/調用方法:
'*/    Dim OutData() As Byte
'*/    If B64U(Text2.Text, OutData) = True Then
'*?       如果原來是ASC碼進去加密的用這個語句
'*/       'Text1.Text = StrConv(OutData, vbUnicode)
'*/       '如果原來是UNICODE進去加密的,用這個,這就要根據實際情況調整了
'*/       Text1.Text = CStr(OutData)
'*/    End If
'*/-------------------------------------------------------------
Public Function B64U(ByVal inData As String, OutData() As Byte) As Boolean
    On Error GoTo Errhandle
    Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim UB As Long, lB As Long                 '數組的上限和下限
    Dim sOut, cOut, i
    Dim nGroup   As Long
    Dim pOut, sGroup
    inData = Replace(inData, vbCrLf, "")
    ReDim OutData(0 To (Int(Len(inData) / 4) + 1) * 3 - 1) As Byte
    For i = 1 To (Len(inData) - Len(inData) Mod 4) Step 4
        nGroup = &O1000000 * (InStr(Base64, Mid(inData, i, 1)) - 1) + &O10000 * (InStr(Base64, Mid(inData, i + 1, 1)) - 1) + _
                        &O100 * (IIf(InStr(Base64, Mid(inData, i + 2, 1)) = 0, 1, InStr(Base64, Mid(inData, i + 2, 1))) - 1) _
                        + (IIf(InStr(Base64, Mid(inData, i + 3, 1)) = 0, 1, InStr(Base64, Mid(inData, i + 3, 1))) - 1)
        sGroup = Trim(Hex(nGroup))                                            '轉成16位的
        sGroup = String(6 - Len(sGroup), "0") & sGroup                                   '如果不夠六位用0去補
        OutData(Int(i / 4) * 3) = Val("&H" & Mid(sGroup, 1, 2))
        OutData(Int(i / 4) * 3 + 1) = Val("&H" & Mid(sGroup, 3, 2))
        OutData(Int(i / 4) * 3 + 2) = Val("&H" & Mid(sGroup, 5, 2))
    Next i
    Select Case Len(inData) - Len(Replace(inData, "=", ""))
    Case 1
        ReDim Preserve OutData(0 To (Int(Len(inData) / 4) + 1) * 3 - 2) As Byte
    Case 2
        ReDim Preserve OutData(0 To (Int(Len(inData) / 4) + 1) * 3 - 3) As Byte
    End Select
    B64U = True
    Exit Function
Errhandle:
    B64U = False
End Function