compfile.bas

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

Attribute VB_Name = "CompFile"
'* Module to Compress AND Encrypt in Tandem
'* Copyright 1999 Patterson Programming

DefInt A-Z

Const N = 4096
Const F = 18
Const NIL = N
Const THRESHOLD = 2
Dim Infinity&

Dim textsize As Long
Dim codesize As Long
Dim textbuf(N + F - 1) As Byte
Dim matchposition As Integer, matchlength As Byte
Dim lson(N + 1) As Integer
Dim rson(N + 257) As Integer
Dim dad(N + 1) As Integer

Dim Infile As Integer, Outfile As Integer, Stuffing As Byte
Dim InLen&, OutLen&, ShortBuffer&, BufferNumber&, ShortOne&
Dim InPointer&, OutPointer&, InFilePointer&, OutFilePointer&

Private Sub FInitTree()

    Dim i As Integer
    For i = N + 1 To (N + 256): rson(i) = NIL: Next
    For i = 0 To N - 1: dad(i) = NIL: Next

End Sub

Private Sub FInsertNode(ByVal r As Integer)

    Dim i As Integer, p As Integer, cmp As Integer
    Dim key As Integer
    Dim x&, x1 As Integer, x2 As Integer

    cmp = 1
    key = r
    p = N + 1 + textbuf(r)
    rson(r) = NIL: lson(r) = NIL
    matchlength = 0

    Infinity& = 2147483647
    For x& = 0 To Infinity&
        If cmp >= 0 Then
            If rson(p) <> NIL Then
                p = rson(p)
            Else
                rson(p) = r
                dad(r) = p
                Exit Sub
            End If
        Else
            If lson(p) <> NIL Then
                p = lson(p)
            Else
                lson(p) = r
                dad(r) = p
                Exit Sub
            End If
        End If
        For i = 1 To F - 1
        x1 = textbuf(r + i): x2 = textbuf(p + i)
            cmp = x1 - x2
            If cmp <> 0 Then Exit For
        Next
        If i > matchlength Then
            matchposition = p
            matchlength = i
            If matchlength >= F Then
                Exit For
            End If
        End If
    Next
    dad(r) = dad(p): lson(r) = lson(p): rson(r) = rson(p)
    dad(lson(p)) = r: dad(rson(p)) = r
    If rson(dad(p)) = p Then
        rson(dad(p)) = r
    Else
        lson(dad(p)) = r
    End If
    dad(p) = NIL

End Sub

Private Sub FDeleteNode(ByVal p As Integer)

    Dim q As Integer

    If dad(p) = NIL Then Exit Sub
    If rson(p) = NIL Then
        q = lson(p)
    ElseIf lson(p) = NIL Then
        q = rson(p)
    Else
        q = lson(p)
        If rson(q) <> NIL Then
            Do
                q = rson(q)
            Loop While rson(q) <> NIL
            rson(dad(q)) = lson(q)
            dad(lson(q)) = dad(q)
            lson(q) = lson(p)
            dad(lson(p)) = q
        End If
        rson(q) = rson(p)
        dad(rson(p)) = q
    End If
    dad(q) = dad(p)
    If rson(dad(p)) = p Then
        rson(dad(p)) = q
    Else
        lson(dad(p)) = q
    End If
    dad(p) = NIL

End Sub

Sub LZCompFile(file1, file2)

    Infile = file1
    Outfile = file2

    Dim codebuf(17) As Byte, codebufptr As Integer
    Dim i As Integer, cc As Byte, r As Integer, s As Integer
    Dim lenn As Integer, lastmatchlength As Integer, mask As Byte

    FInitTree
    codebuf(0) = 0
    codebufptr = 1: mask = 1
    s = 0: r = N - F
    For i = s To r - 1: textbuf(i) = 32: Next

    OpenBuffer

    For lenn = 0 To F - 1
        If InFilePointer& = InLen& Then Exit For
        cc = EnGetByte
        textbuf(r + lenn) = cc
    Next
    textsize = lenn
    If textsize = 0 Then Exit Sub
    For i = 1 To F
        FInsertNode (r - i)
    Next
    FInsertNode (r)
    Do
        If matchlength > lenn Then matchlength = lenn
        If matchlength <= THRESHOLD Then
            matchlength = 1
            codebuf(0) = (codebuf(0) Or mask)
            codebuf(codebufptr) = textbuf(r)
            codebufptr = codebufptr + 1
        Else
            codebuf(codebufptr) = (matchposition And 255)
            codebufptr = codebufptr + 1
            codebuf(codebufptr) = (((matchposition \ 16) And 240) Or _
                               (matchlength - (THRESHOLD + 1))) And 255
            codebufptr = codebufptr + 1
        End If
        mask = (mask * 2) And 255
        If mask = 0 Then
            For i = 0 To codebufptr - 1
                EnPutByte codebuf(i)
            Next
            codesize = codesize + codebufptr
            codebuf(0) = 0
            mask = 1
            codebufptr = mask
        End If
        lastmatchlength = matchlength
        For i = 0 To lastmatchlength - 1

            If InFilePointer& = InLen& Then Exit For
            cc = EnGetByte
            FDeleteNode (s)

            textbuf(s) = cc
            If s < (F - 1) Then textbuf(s + N) = cc
            s = (s + 1) And (N - 1): r = (r + 1) And (N - 1)
            FInsertNode (r)
        Next
        textsize = textsize + i
        While i < lastmatchlength
            i = i + 1

            FDeleteNode (s)

            s = (s + 1) And (N - 1): r = (r + 1) And (N - 1)
            lenn = lenn - 1
            If lenn <> 0 Then FInsertNode (r)
        Wend
    Loop While lenn > 0

    If codebufptr > 1 Then
        For i = 0 To codebufptr - 1
            EnPutByte codebuf(i)
        Next
        codesize = codesize + codebufptr
    End If

    '* encrypt/write compressed data
    '* flush shortbuffer or whole file
    ShortBlockLen% = OutPointer& Mod BlockLen%
    Stuffing = (BlockLen% - ShortBlockLen%) And &HFF
    For p& = 0 To OutPointer& - 1
        CryptBuffer(p&) = OutBuffer(p&)
    Next
    OutPointer& = OutPointer& + Stuffing
    CryptBuffer(OutPointer& - 1) = Stuffing

    FullBlocks& = OutPointer& \ BlockLen%
    BufferPointer& = 0
    SelectCipher (FullBlocks&)
    For p& = 0 To OutPointer& - 1
        OutBuffer(p&) = CryptBuffer(p&)
    Next

    FlushBuffer

End Sub

Sub LZDecompFile(file1, file2)

    Infile = file1
    Outfile = file2

    Dim flags As Byte, flagcount As Byte
    Dim x&, bb As Byte, b1 As Byte, b2 As Byte
    Dim i As Integer, j As Integer, k As Integer, r As Integer

    For i = 0 To (N - F) - 1: textbuf(i) = 32: Next
    r = N - F: flags = 0
    flagcount = 8

    OpenBuffer
    ShortBuffer& = InLen& Mod BUFFERSIZE
    ShortOne& = InLen& \ BUFFERSIZE
    If ShortBuffer& <> 0 Then
        ShortOne& = ShortOne& + 1
    Else
        ShortOne& = -1
    End If

    If InLen& < BUFFERSIZE Then
        CryptLen& = InLen&
    Else
        CryptLen& = BUFFERSIZE
    End If

    '* decrypt data to decompress
    '* buffer #1, or whole file
    FullBlocks& = CryptLen& \ BlockLen%
    ShortBlockLen% = CryptLen& Mod BlockLen%
    For p& = 0 To CryptLen& - 1
        CryptBuffer(p&) = InBuffer(p&)
    Next
    BufferPointer& = 0
    SelectCipher (FullBlocks&)
    For p& = 0 To CryptLen& - 1
        InBuffer(p&) = CryptBuffer(p&)
    Next
    '* get rid of stuffing
    If CryptLen& = InLen& Then
        InLen& = InLen& - InBuffer(CryptLen& - 1)
    End If
    BufferNumber& = 2

    Infinity& = 2147483647
    For x& = 0 To Infinity&
        If flagcount = 8 Then
            If InFilePointer& = InLen& Then Exit For
            bb = DeGetByte()
            flagcount = 0: flags = bb
        End If
        If (flags And 1) = 1 Then
            If InFilePointer& = InLen& Then Exit For
            bb = DeGetByte()
            DePutByte bb
            textbuf(r) = bb: r = r + 1
            r = (r And (N - 1))
        Else
            If InFilePointer& = InLen& Then Exit For
            b1 = DeGetByte()
            If InFilePointer& = InLen& Then Exit For
            b2 = DeGetByte()
            i = b1: j = b2
            i = i Or ((j And 240) * 16)
            j = (j And 15) + THRESHOLD
            For k = 0 To j
                bb = textbuf((i + k) And (N - 1))
                DePutByte bb
                textbuf(r) = bb
                r = r + 1
                r = (r And (N - 1))
            Next
        End If
        flags = (flags \ 2)
        flagcount = flagcount + 1
    Next

    FlushBuffer

End Sub

Function EnGetByte()

    InFilePointer& = InFilePointer& + 1
    If InPointer& = BUFFERSIZE Then
        Get Infile, , InBuffer
        EnGetByte = InBuffer(0)
        InPointer& = 1
    Else
        EnGetByte = InBuffer(InPointer&)
        InPointer& = InPointer& + 1
    End If

End Function

Sub EnPutByte(TheByte As Byte)

    OutFilePointer& = OutFilePointer& + 1
    If OutPointer& = BUFFERSIZE - 1 Then
        OutBuffer(BUFFERSIZE - 1) = TheByte
        For p& = 0 To BUFFERSIZE - 1
            CryptBuffer(p&) = OutBuffer(p&)
        Next
        BufferPointer& = 0
        SelectCipher (BUFFERSIZE \ BlockLen%)
        Put Outfile, , CryptBuffer
        OutPointer& = 0
    Else
        OutBuffer(OutPointer&) = TheByte
        OutPointer& = OutPointer& + 1
    End If

End Sub

Function DeGetByte()

    InFilePointer& = InFilePointer& + 1
    If InPointer& = BUFFERSIZE Then
        Get Infile, , CryptBuffer
        If BufferNumber& = ShortOne& Then
            ShortFlag% = -1
            ShortBufferBlocks& = ShortBuffer& \ BlockLen%
            Blocks& = ShortBufferBlocks&
        Else
            Blocks& = BUFFERSIZE \ BlockLen%
            BufferNumber& = BufferNumber& + 1
        End If
        BufferPointer& = 0
        SelectCipher (Blocks&)
        '* adjust for stuffing if shortbuffer
        If ShortFlag% Then
            Stuffing = CryptBuffer(ShortBuffer& - 1)
            InLen& = InLen& - Stuffing
        End If
        For p& = 0 To BUFFERSIZE - 1
            InBuffer(p&) = CryptBuffer(p&)
        Next
        DeGetByte = InBuffer(0)
        InPointer& = 1
    Else
        DeGetByte = InBuffer(InPointer&)
        InPointer& = InPointer& + 1
    End If

End Function

Sub DePutByte(TheByte As Byte)

    OutFilePointer& = OutFilePointer& + 1
    If OutPointer& = BUFFERSIZE - 1 Then
        OutBuffer(BUFFERSIZE - 1) = TheByte
        Put Outfile, , OutBuffer
        OutPointer& = 0
    Else
        OutBuffer(OutPointer&) = TheByte
        OutPointer& = OutPointer& + 1
    End If

End Sub

Sub OpenBuffer()

    ReDim InBuffer(BUFFERSIZE - 1) As Byte
    ReDim OutBuffer(BUFFERSIZE - 1) As Byte
    InLen& = DataLen&
    '* prime the buffer
    Get Infile, , InBuffer
    InPointer& = 0: InFilePointer& = 0
    OutPointer& = 0: OutFilePointer& = 0

End Sub

Sub FlushBuffer()

    If OutPointer& > 0 Then
        ReDim Preserve OutBuffer(OutPointer& - 1)
        Put Outfile, , OutBuffer
    End If

End Sub