李大仁博客

'VBA Base64 编码/加密函数：
Function Base64Encode(StrA As String) As String                                  'Base64 编码
    On Error GoTo over                                                          '排错
    Dim buf() As Byte, length As Long, mods As Long
    Dim Str() As Byte
    Dim i, kk As Integer
    kk = Len(StrA) - 1
    ReDim Str(kk)
    For i = 0 To kk
        Str(i) = Asc(Mid(StrA, i + 1, 1))
    Next i
    Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    mods = (UBound(Str) + 1) Mod 3   '除以3的余数
    length = UBound(Str) + 1 - mods
    ReDim buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1)
    For i = 0 To length - 1 Step 3
        buf(i / 3 * 4) = (Str(i) And &HFC) / &H4
        buf(i / 3 * 4 + 1) = (Str(i) And &H3) * &H10 + (Str(i + 1) And &HF0) / &H10
        buf(i / 3 * 4 + 2) = (Str(i + 1) And &HF) * &H4 + (Str(i + 2) And &HC0) / &H40
        buf(i / 3 * 4 + 3) = Str(i + 2) And &H3F
    Next
    If mods = 1 Then
        buf(length / 3 * 4) = (Str(length) And &HFC) / &H4
        buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10
        buf(length / 3 * 4 + 2) = 64
        buf(length / 3 * 4 + 3) = 64
    ElseIf mods = 2 Then
        buf(length / 3 * 4) = (Str(length) And &HFC) / &H4
        buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 + (Str(length + 1) And &HF0) / &H10
        buf(length / 3 * 4 + 2) = (Str(length + 1) And &HF) * &H4
        buf(length / 3 * 4 + 3) = 64
    End If
    For i = 0 To UBound(buf)
        Base64Encode = Base64Encode + Mid(B64_CHAR_DICT, buf(i) + 1, 1)
    Next
over:
End Function

'VBA Base64 编码/加密函数： Function Base64Encode(StrA As String) As String 'Base64 编码 On Error GoTo over '排错 Dim buf() As Byte, length As Long, mods As Long Dim Str() As Byte Dim i, kk As Integer kk = Len(StrA) - 1 ReDim Str(kk) For i = 0 To kk Str(i) = Asc(Mid(StrA, i + 1, 1)) Next i Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" mods = (UBound(Str) + 1) Mod 3 '除以3的余数 length = UBound(Str) + 1 - mods ReDim buf(length / 3 * 4 + IIf(mods <> 0, 4, 0) - 1) For i = 0 To length - 1 Step 3 buf(i / 3 * 4) = (Str(i) And &HFC) / &H4 buf(i / 3 * 4 + 1) = (Str(i) And &H3) * &H10 + (Str(i + 1) And &HF0) / &H10 buf(i / 3 * 4 + 2) = (Str(i + 1) And &HF) * &H4 + (Str(i + 2) And &HC0) / &H40 buf(i / 3 * 4 + 3) = Str(i + 2) And &H3F Next If mods = 1 Then buf(length / 3 * 4) = (Str(length) And &HFC) / &H4 buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 buf(length / 3 * 4 + 2) = 64 buf(length / 3 * 4 + 3) = 64 ElseIf mods = 2 Then buf(length / 3 * 4) = (Str(length) And &HFC) / &H4 buf(length / 3 * 4 + 1) = (Str(length) And &H3) * &H10 + (Str(length + 1) And &HF0) / &H10 buf(length / 3 * 4 + 2) = (Str(length + 1) And &HF) * &H4 buf(length / 3 * 4 + 3) = 64 End If For i = 0 To UBound(buf) Base64Encode = Base64Encode + Mid(B64_CHAR_DICT, buf(i) + 1, 1) Next over: End Function

'VBA Base64 解码/解密函数：
Function Base64Decode(B64 As String) As String                                  'Base64 解码
    On Error GoTo over                                                          '排错
    Dim OutStr() As Byte, i As Long, j As Long
    Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    If InStr(1, B64, "=") <> 0 Then B64 = Left(B64, InStr(1, B64, "=") - 1)     '判断Base64真实长度,除去补位
    Dim kk, length As Long, mods As Long
    mods = Len(B64) Mod 4
    length = Len(B64) - mods
    ReDim OutStr(length / 4 * 3 - 1 + Switch(mods = 0, 0, mods = 2, 1, mods = 3, 2))
    For i = 1 To length Step 4
        Dim buf(3) As Byte
        For j = 0 To 3
            buf(j) = InStr(1, B64_CHAR_DICT, Mid(B64, i + j, 1)) - 1            '根据字符的位置取得索引值
        Next
        OutStr((i - 1) / 4 * 3) = buf(0) * &H4 + (buf(1) And &H30) / &H10
        OutStr((i - 1) / 4 * 3 + 1) = (buf(1) And &HF) * &H10 + (buf(2) And &H3C) / &H4
        OutStr((i - 1) / 4 * 3 + 2) = (buf(2) And &H3) * &H40 + buf(3)
    Next
    If mods = 2 Then
        OutStr(length / 4 * 3) = (InStr(1, B64_CHAR_DICT, Mid(B64, length + 1, 1)) - 1) * &H4 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &H30) / 16
    ElseIf mods = 3 Then
        OutStr(length / 4 * 3) = (InStr(1, B64_CHAR_DICT, Mid(B64, length + 1, 1)) - 1) * &H4 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &H30) / 16
        OutStr(length / 4 * 3 + 1) = ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &HF) * &H10 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 3, 1)) - 1) And &H3C) / &H4
    End If
    For i = 0 To UBound(OutStr)
        Base64Decode = Base64Decode & Chr(OutStr(i))
    Next i                                                       '读取解码结果
over:
End Function

'VBA Base64 解码/解密函数： Function Base64Decode(B64 As String) As String 'Base64 解码 On Error GoTo over '排错 Dim OutStr() As Byte, i As Long, j As Long Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" If InStr(1, B64, "=") <> 0 Then B64 = Left(B64, InStr(1, B64, "=") - 1) '判断Base64真实长度,除去补位 Dim kk, length As Long, mods As Long mods = Len(B64) Mod 4 length = Len(B64) - mods ReDim OutStr(length / 4 * 3 - 1 + Switch(mods = 0, 0, mods = 2, 1, mods = 3, 2)) For i = 1 To length Step 4 Dim buf(3) As Byte For j = 0 To 3 buf(j) = InStr(1, B64_CHAR_DICT, Mid(B64, i + j, 1)) - 1 '根据字符的位置取得索引值 Next OutStr((i - 1) / 4 * 3) = buf(0) * &H4 + (buf(1) And &H30) / &H10 OutStr((i - 1) / 4 * 3 + 1) = (buf(1) And &HF) * &H10 + (buf(2) And &H3C) / &H4 OutStr((i - 1) / 4 * 3 + 2) = (buf(2) And &H3) * &H40 + buf(3) Next If mods = 2 Then OutStr(length / 4 * 3) = (InStr(1, B64_CHAR_DICT, Mid(B64, length + 1, 1)) - 1) * &H4 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &H30) / 16 ElseIf mods = 3 Then OutStr(length / 4 * 3) = (InStr(1, B64_CHAR_DICT, Mid(B64, length + 1, 1)) - 1) * &H4 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &H30) / 16 OutStr(length / 4 * 3 + 1) = ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &HF) * &H10 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 3, 1)) - 1) And &H3C) / &H4 End If For i = 0 To UBound(OutStr) Base64Decode = Base64Decode & Chr(OutStr(i)) Next i '读取解码结果 over: End Function