求一份可用的base64编解码

转贴E-MAIL的BASE64编码解码程序
BASE64编码解码程序编码：BASE64
基本公式
B(1) = (Int(A(1) / 4) + 65)
B(2) = ((A(1) Mod 4) * 16 + Int(A(2) / 16) + 65)
B(3) = ((A(2) Mod 16) * 4 + Int(A(3) / 64) + 65)
B(4) = (A(3) Mod 64 + 65)
源文件特殊长度 4，8
编码文件每76个字符插入常数vbCrLf
i Private Sub Command1_Click()
    Command1.Enabled = False
    Dim nFileno1 As Integer
    Dim nFileno2 As Integer
    Dim bByte As Byte
    Dim sInp As String
    Dim nFilelen As Long
    Dim A(3) As Byte
    Dim B(4) As Byte
    nFileno1 = FreeFile
    Open Text1.Text For Binary As #nFileno1
    nFileno2 = FreeFile
    Open Text2.Text For Binary As #nFileno2
    nFilelen = LOF(nFileno1)
    If nFilelen = 0 Then GoTo Fail
    If nFilelen <= 3 Then
        If nFilelen Mod 3 = 1 Then
            Get #nFileno1, , A(1)
            B(1) = (Int(A(1) / 4) + 65)
            B(2) = ((A(1) Mod 4) * 16 + 65)
            B(3) = (61)
            B(4) = (61)
        Else
            If nFilelen Mod 3 = 2 Then
                Get #nFileno1, , A(1)
                Get #nFileno1, , A(2)
                B(1) = (Int(A(1) / 4) + 65)
                B(2) = ((A(1) Mod 4) * 16 + Int(A(2) / 16) + 65)
                B(3) = ((A(2) Mod 16) * 4 + 65 + 1)
                B(4) = (61)
            Else
                Get #nFileno1, , A(1)
                Get #nFileno1, , A(2)
                Get #nFileno1, , A(3)
                B(1) = (Int(A(1) / 4) + 65)
                B(2) = ((A(1) Mod 4) * 16 + Int(A(2) / 16) + 65)
                B(3) = ((A(2) Mod 16) * 4 + Int(A(3) / 64) + 65)
                B(4) = (A(3) Mod 64 + 65)
            End If
        End If
        For nI = 1 To 4 Step 1
            If B(nI) > 90 And B(nI) <= 116 Then
                B(nI) = B(nI) + 6
            Else
                If B(nI) > 116 And B(nI) <= 126 Then
                    B(nI) = B(nI) - 69
                Else
                    If B(nI) = 127 Then B(nI) = 43
                    If B(nI) = 128 Then B(nI) = 47
                End If
            End If
        Next nI
        Put #nFileno2, , B(1)
        Put #nFileno2, , B(2)
        Put #nFileno2, , B(3)
        Put #nFileno2, , B(4)
    Else
        nJ = Int(nFilelen / 3) * 3
        Do While Loc(nFileno1) < nJ
            For nI = 1 To 3 Step 1
                Get #nFileno1, , (A(nI))
            Next nI
            B(1) = (Int(A(1) / 4) + 65)
            B(2) = ((A(1) Mod 4) * 16 + Int(A(2) / 16) + 65)
            B(3) = ((A(2) Mod 16) * 4 + Int(A(3) / 64) + 65)
            B(4) = (A(3) Mod 64 + 65)
            For nI = 1 To 4 Step 1
                If B(nI) > 90 And B(nI) <= 116 Then
                    B(nI) = B(nI) + 6
                Else
                    If B(nI) > 116 And B(nI) <= 126 Then
                        B(nI) = B(nI) - 69
                    Else
                        If B(nI) = 127 Then B(nI) = 43
                        If B(nI) = 128 Then B(nI) = 47
                    End If
                End If
            Next nI
            Put #nFileno2, , B(1)
            Put #nFileno2, , B(2)
            Put #nFileno2, , B(3)
            Put #nFileno2, , B(4)
            If Int((Loc(nFileno2) + 2) / 78) = (Loc(nFileno2) + 2) / 78 Then
                Put #nFileno2, , vbCrLf
            End If
        Loop
        If nFilelen Mod 3 = 1 Then
            Get #nFileno1, , A(1)
            B(1) = (Int(A(1) / 4) + 65)
            B(2) = ((A(1) Mod 4) * 16 + 65)
            If nFilelen = 4 Then B(2) = B(2) + 3
            B(3) = (61)
            B(4) = (61)
            For nI = 1 To 4 Step 1
                If B(nI) > 90 And B(nI) <= 116 Then
                    B(nI) = B(nI) + 6
                Else
                    If B(nI) > 116 And B(nI) <= 126 Then
                        B(nI) = B(nI) - 69
                    Else
                        If B(nI) = 127 Then B(nI) = 43
                        If B(nI) = 128 Then B(nI) = 47
                    End If
                End If
            Next nI
            Put #nFileno2, , B(1)
            Put #nFileno2, , B(2)
            Put #nFileno2, , B(3)
            Put #nFileno2, , B(4)
            If Int((Loc(nFileno2) + 2) / 78) = (Loc(nFileno2) + 2) / 78 Then
                Put #nFileno2, , vbCrLf
            End If
        Else
            If nFilelen Mod 3 = 2 Then
                Get #nFileno1, , A(1)
                Get #nFileno1, , A(2)
                B(1) = (Int(A(1) / 4) + 65)
                B(2) = ((A(1) Mod 4) * 16 + Int(A(2) / 16) + 65)
                B(3) = ((A(2) Mod 16) * 4 + 65)
                If nFilelen = 8 Then B(3) = B(3) + 1
                B(4) = (61)
                For nI = 1 To 4 Step 1
                    If B(nI) > 90 And B(nI) <= 116 Then
                        B(nI) = B(nI) + 6
                    Else
                        If B(nI) > 116 And B(nI) <= 126 Then
                            B(nI) = B(nI) - 69
                        Else
                            If B(nI) = 127 Then B(nI) = 43
                            If B(nI) = 128 Then B(nI) = 47
                        End If
                    End If
                Next nI
                Put #nFileno2, , B(1)
                Put #nFileno2, , B(2)
                Put #nFileno2, , B(3)
                Put #nFileno2, , B(4)
                If Int((Loc(nFileno2) + 2) / 78) = (Loc(nFileno2) + 2) / 78 Then
                    Put #nFileno2, , vbCrLf
                End If
            End If
        End If
    End If
    MsgBox Str(nFilelen), vbOKOnly
    'MsgBox Str(Loc(nFileno1)), vbOKOnly
    Close #nFileno1
    Close #nFileno2
    Command1.Enabled = True
    Exit Sub
Fail:
    MsgBox "打开文件长度为零，无法编码！", , "警告"
End Sub

Option Base 0
Private aDecTab(255) As Integer
Private Const sEncTab As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"Public Function EncodeStr64(sInput As String) As String
' Return radix64 encoding of string of binary values
' Does not insert CRLFs. Just returns one long string,
' so it's up to the Group to add line breaks or other formatting.
    Dim sOutput As String, sLast As String
    Dim b(2) As Byte
    Dim j As Integer
    Dim i As Long, nLen As Long, nQuants As Long

    nLen = Len(sInput)
    nQuants = nLen \ 3
    sOutput = ""
    ' Now start reading in 3 bytes at a time
    For i = 0 To nQuants - 1
        For j = 0 To 2
           b(j) = Asc(Mid(sInput, (i * 3) + j + 1, 1))
        Next
        sOutput = sOutput & EncodeQuantum(b)
    Next

    ' Cope with odd bytes
    Select Case nLen Mod 3
    Case 0
        sLast = ""
    Case 1
        b(0) = Asc(Mid(sInput, nLen, 1))
        b(1) = 0
        b(2) = 0
        sLast = EncodeQuantum(b)
        ' Replace last 2 with =
        sLast = Left(sLast, 2) & "=="
    Case 2
        b(0) = Asc(Mid(sInput, nLen - 1, 1))
        b(1) = Asc(Mid(sInput, nLen, 1))
        b(2) = 0
        sLast = EncodeQuantum(b)
        ' Replace last with =
        sLast = Left(sLast, 3) & "="
    End Select

    EncodeStr64 = sOutput & sLast
End FunctionPublic Function DecodeStr64(sEncoded As String) As String
' Return string of decoded binary values given radix64 string
' Ignores any chars not in the 64-char subset
    Dim sDecoded As String
    Dim d(3) As Byte
    Dim c As Byte
    Dim di As Integer
    Dim i As Long

    sDecoded = ""
    di = 0
    Call MakeDecTab
    ' Read in each char in trun
    For i = 1 To Len(sEncoded)
        c = CByte(Asc(Mid(sEncoded, i, 1)))
        c = aDecTab(c)
        If c >= 0 Then
            d(di) = c
            di = di + 1
            If di = 4 Then
                sDecoded = sDecoded & DecodeQuantum(d)
                If d(3) = 64 Then
                    sDecoded = Left(sDecoded, Len(sDecoded) - 1)
                End If
                If d(2) = 64 Then
                    sDecoded = Left(sDecoded, Len(sDecoded) - 1)
                End If
                di = 0
            End If
        End If
    Next i

    DecodeStr64 = sDecoded
End Function

Private Function EncodeQuantum(b() As Byte) As String
    Dim sOutput As String
    Dim c As Integer
    sOutput = ""
    c = SHR(b(0), 2) And &H3F
    sOutput = sOutput & Mid(sEncTab, c + 1, 1)
    c = SHL(b(0) And &H3, 4) Or (SHR(b(1), 4) And &HF)
    sOutput = sOutput & Mid(sEncTab, c + 1, 1)
    c = SHL(b(1) And &HF, 2) Or (SHR(b(2), 6) And &H3)
    sOutput = sOutput & Mid(sEncTab, c + 1, 1)
    c = b(2) And &H3F
    sOutput = sOutput & Mid(sEncTab, c + 1, 1)

    EncodeQuantum = sOutput
End FunctionPrivate Function DecodeQuantum(d() As Byte) As String
    Dim sOutput As String
    Dim c As Long

    sOutput = ""
    c = SHL(d(0), 2) Or (SHR(d(1), 4) And &H3)
    sOutput = sOutput & Chr$(c)
    c = SHL(d(1) And &HF, 4) Or (SHR(d(2), 2) And &HF)
    sOutput = sOutput & Chr$(c)
    c = SHL(d(2) And &H3, 6) Or d(3)
    sOutput = sOutput & Chr$(c)

    DecodeQuantum = sOutput
End FunctionPrivate Function MakeDecTab()
' Set up Radix 64 decoding table
    Dim t As Integer
    Dim c As Integer
    For c = 0 To 255
        aDecTab(c) = -1
    Next
    t = 0
    For c = Asc("A") To Asc("Z")
        aDecTab(c) = t
        t = t + 1
    Next
    For c = Asc("a") To Asc("z")
        aDecTab(c) = t
        t = t + 1
    Next
    For c = Asc("0") To Asc("9")
        aDecTab(c) = t
        t = t + 1
    Next
    c = Asc("+")
    aDecTab(c) = t
    t = t + 1
    c = Asc("/")
    aDecTab(c) = t
    t = t + 1
    c = Asc("=")    ' flag for the byte-deleting char
    aDecTab(c) = t  ' should be 64
End FunctionPrivate Function SHL(ByVal bytValue As Byte, intShift As Integer) As Byte
    If intShift > 0 And intShift < 8 Then
        SHL = bytValue * (2 ^ intShift) Mod 256
    ElseIf intShift = 0 Then
        SHL = bytValue
    Else
        SHL = 0
    End If
End FunctionPrivate Function SHR(ByVal bytValue As Byte, intShift As Integer) As Byte
    If intShift > 0 And intShift < 8 Then
        SHR = bytValue \ (2 ^ intShift)
    ElseIf intShift = 0 Then
        SHR = bytValue
    Else
        SHR = 0
    End If
End Function注意以上代码不适用汉字加密

'****************************************************
'base65 编码算法函数对邮件进行编码
'*****************************************************
Private Function Base64_Encode(strSource) As String 'base64加密算法
    Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim strTempLine As String
    Dim j As Integer
    For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 _
                      + Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
    Next j
    If Not (Len(strSource) Mod 3) = 0 Then
         If (Len(strSource) Mod 3) = 2 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
             strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 + 1, 1)
            strTempLine = strTempLine & "="
        ElseIf (Len(strSource) Mod 3) = 1 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 + 1, 1)
             strTempLine = strTempLine & "=="
        End If
     End If
    Base64_Encode = strTempLine
End Function
'*************************************************************
'Option ExplicitPublic Function Base64_Encode(strSource As String, strTempLine) 'base64加密算法
    Const BASE64_TABLE As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

    Dim j As Long
    For j = 1 To (Len(strSource) - Len(strSource) Mod 3) Step 3
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, ((Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 _
                      + Asc(Mid(strSource, j + 2, 1)) \ 64) + 1, 1)
        strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 2, 1)) Mod 64) + 1, 1)
    Next j
    If Not (Len(strSource) Mod 3) = 0 Then
         If (Len(strSource) Mod 3) = 2 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) \ 4) + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 _
                      + Asc(Mid(strSource, j + 1, 1)) \ 16 + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j + 1, 1)) Mod 16) * 4 + 1, 1)
            strTempLine = strTempLine & "="
        ElseIf (Len(strSource) Mod 3) = 1 Then
            strTempLine = strTempLine + Mid(BASE64_TABLE, Asc(Mid(strSource, j, 1)) \ 4 + 1, 1)
            strTempLine = strTempLine + Mid(BASE64_TABLE, (Asc(Mid(strSource, j, 1)) Mod 4) * 16 + 1, 1)
            strTempLine = strTempLine & "=="
        End If
     End If

End Function

调试易

求一份可用的base64编解码

解决方案 »