VBA版Deflate

BitWriter.bas

' public domain
Option Explicit

Private FOut%
Private buf() As Byte
Private bufp&, cur&, bit%

Public Sub BitWriter_Init(FO%)
    ReDim buf(4095)
    FOut = FO
    bufp = 0
    cur = 0
    bit = 0
End Sub

Public Sub BitWriter_WriteByte(ByVal B As Byte)
    buf(bufp) = B
    If bufp < 4095 Then
        bufp = bufp + 1
    Else
        Put #FOut, , buf
        bufp = 0
    End If
End Sub

Public Sub BitWriter_Close()
    If bit > 0 Then
        BitWriter_WriteByte cur
        cur = 0
        bit = 0
    End If
    If bufp > 0 Then
        ReDim Preserve buf(bufp - 1)
        Put #FOut, , buf
        ReDim buf(4095)
        bufp = 0
    End If
End Sub

Public Sub BitWriter_WriteBit(B As Boolean)
    If B Then cur = cur Or sl(1, bit, 0)
    If bit < 7 Then
        bit = bit + 1
    Else
        BitWriter_WriteByte cur
        cur = 0
        bit = 0
    End If
End Sub

Public Sub BitWriter_WriteBits(Length%, ByVal B%)
    Dim v As Byte, pos%
    If Length > 0 Then
        v = cur Or sl(B, bit, 0)
        pos = bit + Length
        If pos < 8 Then
            cur = v
            bit = pos
        Else
            BitWriter_WriteByte v
            If pos < 16 Then
                cur = sl(B, bit, 1)
                bit = pos - 8
            Else
                BitWriter_WriteByte sl(B, bit, 1)
                cur = sl(B, bit, 2)
                bit = pos - 16
            End If
        End If
    End If
End Sub

Public Sub BitWriter_WriteFixedHuffman(ByVal B%)
    If B < 144 Then
        BitWriter_WriteBits 8, rev(B + 48)
    ElseIf B < 256 Then
        BitWriter_WriteBit True
        BitWriter_WriteBits 8, rev(B)
    ElseIf B < 280 Then
        BitWriter_WriteBits 7, rev(B + B - 512)
    ElseIf B < 288 Then
        BitWriter_WriteBits 8, rev(B - 88)
    End If
End Sub

Public Sub BitWriter_WriteLen(Length&)
    Dim ll&
    ll = litindex(Length - 3)
    BitWriter_WriteFixedHuffman ll
    BitWriter_WriteBits litexlens(ll), Length - litlens(ll)
End Sub

Public Sub BitWriter_WriteDist(d&)
    Dim dl&
    dl = distindex(d - 1)
    BitWriter_WriteBits 5, rev(dl * 8)
    BitWriter_WriteBits distexlens(dl), d - distlens(dl)
End Sub

Deflate.bas

' public domain
Option Explicit

Public Const maxlen& = 258, maxdist& = 32768
Public litexlens%(285), litlens&(285), litindex&(maxlen - 3)
Public distexlens%(29), distlens&(29), distindex&(maxdist - 1)
Public sl(8191, 7, 2) As Byte, rev(255) As Byte
Public hashseed%(255, 255)

Public Sub Deflate_Init()
    Dim I&, J&, v&, P2&
    Dim P2R As Byte, B As Byte

    For I = 0 To 255
        For J = 0 To 255
            hashseed(I, J) = (I * 16) Xor (J * 4)
        Next J
    Next I

    For I = 265 To 284
        litexlens(I) = (I - 261) \ 4
    Next I

    v = 3
    For I = 257 To 284
        litlens(I) = v
        P2 = 1
        For J = 1 To litexlens(I)
            P2 = P2 + P2
        Next J
        For J = 1 To P2
            litindex(v - 3) = I
            v = v + 1
        Next J
    Next I
    litlens(285) = maxlen
    litindex(maxlen - 3) = 285

    For I = 4 To 29
        distexlens(I) = (I - 2) \ 2
    Next I

    v = 1
    For I = 0 To 29
        distlens(I) = v
        P2 = 1
        For J = 1 To distexlens(I)
            P2 = P2 + P2
        Next
        For J = 1 To P2
            distindex(v - 1) = I
            v = v + 1
        Next J
    Next I

    For I = 0 To 8191
        P2 = 1
        For J = 0 To 7
            v = I * P2
            sl(I, J, 0) = v And 255
            sl(I, J, 1) = (v \ 256) And 255
            sl(I, J, 2) = v \ 65536
            P2 = P2 + P2
        Next J
    Next I

    For I = 0 To 255
        P2 = 1
        P2R = 128
        B = 0
        For J = 0 To 7
            If I And P2 Then B = B + P2R
            P2 = P2 + P2
            P2R = P2R \ 2
        Next J
        rev(I) = B
    Next I
End Sub

Public Sub Deflate_WriteBytes(FIn%, FOut%)
    If rev(255) = 0 Then Deflate_Init
    DeflateWriter_Compress FIn, FOut
End Sub

Public Sub Deflate_WriteFile(PIn$, POut$)
    Dim FIn%, FOut%
    
    FIn = FreeFile
    Open PIn For Binary Lock Read As #FIn
    
    On Error Resume Next
    Kill POut
    On Error GoTo 0
    FOut = FreeFile
    Open POut For Binary Lock Write As #FOut
    
    Deflate_WriteBytes FIn, FOut
    
    Close #FOut
    Close #FIn
End Sub

Public Sub Deflate_Test(PIn$, POut$)
    Dim T1#, T2#
    T1 = Evaluate("=NOW()")
    Deflate_WriteFile PIn, POut
    T2 = Evaluate("=NOW()")
    Debug.Print (T2 - T1) * 24 * 60 * 60
End Sub

DeflateWriter.bas

' public domain
Option Explicit

Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length&)

Private Const maxbuf& = maxdist * 2
Private Const buflen& = maxbuf + maxlen

Private Length&, bufstart&, filelen&
Private buf(buflen - 1) As Byte
Private tables&(4095, 15), current&(4095)

Private Sub Read(FIn%, pos&, readlen&)
    Dim rbuf() As Byte, rlen&
    rlen = filelen
    If rlen > readlen Then rlen = readlen
    ReDim rbuf(rlen - 1)
    Get #FIn, , rbuf
    RtlMoveMemory buf(pos), rbuf(0), rlen
    filelen = filelen - rlen
    If rlen < readlen Then Length = pos + rlen
End Sub

Private Sub AddHash(pos&)
    Dim h%, C&, b1 As Byte, b2 As Byte
    b1 = buf(pos)
    b2 = buf(pos + 1)
    If b1 <> b2 Then
        h = hashseed(b1, b2) Xor buf(pos + 2)
        C = current(h)
        tables(h, C And 15) = bufstart + pos
        current(h) = C + 1
    End If
End Sub

Private Sub Search(pos&, ByRef rp&, ByRef rl&)
    Dim maxp&, maxl&, mlen&, last&, h%, C&, P1&, I&, P&, l&
    maxp = -1
    maxl = 2
    mlen = Length - pos
    If mlen > maxlen Then mlen = maxlen
    last = pos - maxdist
    If last < 0 Then last = 0
    h = hashseed(buf(pos), buf(pos + 1)) Xor buf(pos + 2)
    C = current(h)
    P1 = IIf(C < 16, 0, C - 16)
    For I = C - 1 To P1 Step -1
        P = tables(h, I And 15) - bufstart
        If P < last Then
            Exit For
        Else
            l = 0
            While l < mlen And buf(P + l) = buf(pos + l)
                l = l + 1
            Wend
            If l > maxl Then
                maxp = P
                maxl = l
            End If
        End If
    Next
    rp = maxp
    rl = maxl
End Sub

Public Sub DeflateWriter_Compress(FIn%, FOut%)
    Length = buflen
    bufstart = 0
    filelen = LOF(FIn)
    
    Dim I&
    For I = 0 To 4095
        current(I) = 0
    Next I
    Read FIn, 0, buflen

    Dim B As Byte
    BitWriter_Init FOut
    Dim P&, l&, mlen&, maxp&, maxl&
    BitWriter_WriteBit True
    BitWriter_WriteBits 2, 1
    While P < Length
        B = buf(P)
        If P < Length - 4 And B = buf(P + 1) And B = buf(P + 2) And B = buf(P + 3) Then
            l = 4
            mlen = Length - P
            If mlen > maxlen + 1 Then mlen = maxlen + 1
            While l < mlen And B = buf(P + l)
                l = l + 1
            Wend
            BitWriter_WriteFixedHuffman B
            BitWriter_WriteLen l - 1
            BitWriter_WriteDist 1
            P = P + l
        Else
            Search P, maxp, maxl
            If maxp < 0 Then
                BitWriter_WriteFixedHuffman B
                AddHash P
                P = P + 1
            Else
                BitWriter_WriteLen maxl
                BitWriter_WriteDist P - maxp
                For I = P To P + maxl - 1
                    AddHash I
                Next
                P = P + maxl
            End If
        End If
        If P > maxbuf Then
            RtlMoveMemory buf(0), buf(maxdist), maxdist + maxlen
            If Length < buflen Then
                Length = Length - maxdist
            Else
                Read FIn, maxdist + maxlen, maxdist
            End If
            P = P - maxdist
            bufstart = bufstart + maxdist
        End If
    Wend
    BitWriter_WriteFixedHuffman 256
    BitWriter_Close
End Sub