radix64.bas

e-maill文件加密程序完整的源代码

Attribute VB_Name = "Base64"
'* Copyright 1999 - Patterson Programming - All Rights Reserved
'* Radix64 routines for native Visual Basic 5/6
'* Used to convert binary data to base-64 (Western Alphabet)
'* A block is 3 binary bytes or 4 characters
'* Standard module: Radix64.BAS
'* User routines: Sub EncodeData, Function DecodeData

DefInt A-Z

Const CR = 13, LF = 10, EOL = 2
Const BlocksPerLine = 16
Const MaxBlock = BlocksPerLine - 1
Const Chars = (BlocksPerLine * 4) + EOL
Const Bins = (BlocksPerLine * 3)

Dim CodeTable(63) As Byte
Dim DecodeTable(255) As Byte
Dim ScanTable(255) As Byte
Dim ReadBase As Long
Dim WriteBase As Long
Dim BinRetLen As Long
Dim CharRetLen As Long
Dim LB((BlocksPerLine * 4) - 1) As Byte

'* Global arrays bin() and ch() declared elsewhere

Sub EncodeData(BinDataLen&, RetLen&)

    InitCodeTables
    ReadBase = 0
    WriteBase = 0
    CharRetLen = 0

    FullLines& = BinDataLen& \ Bins
    ShortLineLen% = BinDataLen& Mod Bins

    For x& = 1 To FullLines&
        RadixEncode MaxBlock, 0
        WriteBase = WriteBase + Chars
        ReadBase = ReadBase + Bins
    Next

    If ShortLineLen% <> 0 Then
        LastBlock% = ShortLineLen% \ 3
        If ShortLineLen% Mod 3 <> 0 Then
            LastBlock% = LastBlock% + 1
            If ShortLineLen% Mod 3 = 1 Then PadLen% = 2
            If ShortLineLen% Mod 3 = 2 Then PadLen% = 1
        End If

        '* subtract one for called subroutine
        RadixEncode LastBlock% - 1, PadLen%
    End If

    RetLen& = CharRetLen

End Sub 'EncodeData


Function DecodeData(CharDataLen&, RetLen&) As Integer

    Dim Abyte As Byte

    InitCodeTables
    ReadBase = 0
    WriteBase = 0
    BinRetLen = 0

    '* skip over header data
    '* without using signature
    chPointer& = 0
    Marker& = 0
    LFpos& = 0
    LineLen& = 0
    SaveLineLen& = 100
    Do
        If chPointer& = CharDataLen& Then Exit Do
        Abyte = ch(chPointer&)
        If Abyte <> 32 Then
            LineLen& = LineLen& + 1
        End If
        '* look for header-type characters
        '* or header-length lines
        If ScanTable(Abyte) = 255 Then
            Marker& = chPointer&
        Else
            If Abyte = 10 Then
                If (LineLen& > SaveLineLen&) Then
                    If chPointer& > SavePoint& Then
                        SavePoint& = (chPointer& - LineLen&)
                    End If
                End If
                If LineLen& <> 2 Then
                    SaveLineLen& = LineLen&
                End If

                If Marker& > LFpos& Then
                    SavePoint& = chPointer&
                End If
                LFpos& = chPointer&
                LineLen& = 0
            End If
        End If

        chPointer& = chPointer& + 1

    Loop While chPointer& < CharDataLen&
    chPointer& = SavePoint&

    If chPointer& >= CharDataLen& - 1 Then
        DecodeData = 0
        Exit Function
    End If

    Do
        Do
            '* skip garbage
            If chPointer& = CharDataLen& Then Exit Do
            SkipIt = 0
            Abyte = ch(chPointer&)
            If Abyte = 13 Or Abyte = 10 Or Abyte = 32 Then
                SkipIt = -1
                chPointer& = chPointer& + 1
            End If
        Loop While SkipIt = -1
        '* copy data
        For x& = 0 To (BlocksPerLine * 4) - 1
            If chPointer& = CharDataLen& Then Exit For
            LB(x&) = ch(chPointer&)
            chPointer& = chPointer& + 1
        Next
        '* do the decode
        LastBlock = x& \ 4
        ReturnCode% = RadixDecode(LastBlock - 1)
        If ReturnCode% Then Exit Do
        Do
            '* skip garbage
            If chPointer& = CharDataLen& Then Exit Do
            SkipIt = 0
            Abyte = ch(chPointer&)
            If Abyte = 13 Or Abyte = 10 Or Abyte = 32 Then
                SkipIt = -1
                chPointer& = chPointer& + 1
            End If
        Loop While SkipIt = -1

    Loop While chPointer& < CharDataLen&

    RetLen& = BinRetLen
    If RetLen& < (BlockLen% * 2) + BlockLen% Then
        DecodeData = 0
    Else
        DecodeData = Not (ReturnCode%)
    End If

End Function 'DecodeData


Private Sub InitCodeTables()

    j% = 0
    For i% = 0 To 255: DecodeTable(i%) = 255: Next
    For i% = 65 To 90
        CodeTable(j%) = i%
        DecodeTable(i%) = j%
        j% = j% + 1
    Next
    For i% = 97 To 122
        CodeTable(j%) = i%
        DecodeTable(i%) = j%
        j% = j% + 1
    Next
    For i% = 48 To 57
        CodeTable(j%) = i%
        DecodeTable(i%) = j%
        j% = j% + 1
    Next
    CodeTable(j%) = 43
    DecodeTable(43) = j%
    j% = j% + 1
    CodeTable(j%) = 47
    DecodeTable(47) = j%
    DecodeTable(61) = 64

    For i% = 0 To 255: ScanTable(i%) = 0: Next
    ScanTable(40) = 255: ScanTable(41) = 255: ScanTable(44) = 255
    ScanTable(45) = 255: ScanTable(46) = 255: ScanTable(58) = 255
    ScanTable(60) = 255: ScanTable(62) = 255: ScanTable(64) = 255

End Sub 'InitCodeTables


Private Static Sub RadixEncode(LastBlock%, PadLen%)
Dim T0 As Integer, T1 As Integer, T2 As Integer, T3 As Integer
Dim j As Long, k As Long

j = ReadBase
k = WriteBase

For i% = 0 To MaxBlock  '* Max line length (in number of blocks) *

    '* compiler should translate this into shifts
    T0 = (bin(j) \ 4) And &H3F
    T1 = ((bin(j) And &H3) * 16) Or ((bin(j + 1) \ 16) And &HF)
    T2 = ((bin(j + 1) And &HF) * 4) Or ((bin(j + 2) \ 64) And &H3)
    T3 = bin(j + 2) And &H3F

    ch(k) = CodeTable(T0) And &HFF
    ch(k + 1) = CodeTable(T1) And &HFF
    ch(k + 2) = CodeTable(T2) And &HFF
    ch(k + 3) = CodeTable(T3) And &HFF

    If i% = LastBlock% Or i% = MaxBlock Then
        If PadLen% > 0 Then
            If PadLen% = 2 Then ch(k + 2) = Asc("="): ch(k + 3) = Asc("=")
            If PadLen% = 1 Then ch(k + 3) = Asc("=")
        End If
        '* save actual character output length
        CharRetLen = (CharRetLen + (i% * 4) + 4 + EOL)

        ch(k + 4) = Asc(Chr$(CR))
        ch(k + 5) = Asc(Chr$(LF))
        Exit For
    End If

    j = j + 3
    k = k + 4

Next

End Sub 'RadixEncode


Private Static Function RadixDecode(LastBlock%) As Integer
Dim x0 As Byte, x1 As Byte, x2 As Byte, x3 As Byte
Dim T0 As Integer, T1 As Integer, T2 As Integer
Dim j As Long, k As Long

j = WriteBase
k = ReadBase

CodeError% = 0: BinPadLen% = 0

For i% = 0 To MaxBlock  '* Max line length (in number of blocks) *

    '* found space or CRLF
    If LB(k) = 13 Or LB(k) = 32 Then
        RadixDecode = CodeError%
        Exit Function
    End If

    x0 = DecodeTable(LB(k))
    If x0 = 255 Then CodeError% = -1

    x1 = DecodeTable(LB(k + 1))
    If x1 = 255 Then CodeError% = -1

    x2 = DecodeTable(LB(k + 2))
    If x2 = 255 Then CodeError% = -1

    x3 = DecodeTable(LB(k + 3))
    If x3 = 255 Then CodeError% = -1

    '* compiler should translate this into shifts
    T0 = (x0 * 4) Or ((x1 \ 16) And &H3)
    T1 = ((x1 And &HF) * 16) Or ((x2 \ 4) And &HF)
    T2 = ((x2 And &H3) * 64) Or x3

    bin(j) = T0 And &HFF
    bin(j + 1) = T1 And &HFF
    bin(j + 2) = T2 And &HFF

    WriteBase = WriteBase + 3

    '* look for "=" symbols
    If x2 = 64 Then
        BinPadLen% = 2
        BinRetLen = BinRetLen + (3 - BinPadLen%)
        Exit For
    ElseIf x3 = 64 Then
        BinPadLen% = 1
        BinRetLen = BinRetLen + (3 - BinPadLen%)
        Exit For
    End If

    '* save actual binary output length
    BinRetLen = BinRetLen + 3

    '* default
    If i% = LastBlock% Or i% = MaxBlock Then
        Exit For
    End If

    j = j + 3
    k = k + 4

Next

RadixDecode = CodeError%

End Function 'RadixDecode

'* End of Module Radix64.BAS