解压VBA流

Public Function Decompression(arrByte() As Byte) As Byte()
    ‘解压VBA流
    ‘算法说明：https://msdn.microsoft.com/en-us/library/cc313094(v=office.12).aspx
    Dim CompressedContainer() As Byte
    Dim SignatureByte As Byte
    Dim CompressedHeader As Integer
    Dim CompressedChunkSize As Integer
    Dim CompressedChunkSignature As Integer
    Dim CompressedChunkFlag As Integer
    Dim CompressedChunkData() As Byte
    Dim DecompressedChunk() As Byte
    Dim CompressedCurrent As Integer
    Dim DecompressedBuffer() As Byte
    Dim DecompressedStart As Long
    Dim DecompressedChunkSize As Integer
    
    If LBound(arrByte) <> 0 Then Exit Function
    
    CompressedContainer = arrByte
    SignatureByte = CompressedContainer(0)
    If SignatureByte <> 1 Then Exit Function
    CompressedCurrent = 1
    DecompressedStart = 0
    Do While CompressedCurrent < UBound(CompressedContainer)
        CopyMemory CompressedHeader, CompressedContainer(CompressedCurrent), 2
        CompressedChunkSize = ExtractCompressedChunkSize(CompressedHeader)
        CompressedChunkSignature = ExtractCompressedChunkSignature(CompressedHeader)
        CompressedChunkFlag = ExtractCompressedChunkFlag(CompressedHeader)
        If CompressedChunkSignature <> 3 Then Exit Function
        
        If CompressedChunkFlag = 0 Then
            Call DecompressingRawChunk
        Else
            ReDim CompressedChunkData(0 To CompressedChunkSize - 1)
            CopyMemory CompressedChunkData(0), CompressedContainer(CompressedCurrent + 2), CompressedChunkSize
            Call DecompressingTokenSequence(CompressedChunkData, DecompressedChunk)
            CompressedCurrent = CompressedCurrent + 2 + CompressedChunkSize
        End If
        DecompressedChunkSize = UBound(DecompressedChunk) + 1
        ReDim Preserve DecompressedBuffer(0 To DecompressedStart + DecompressedChunkSize - 1)
        CopyMemory DecompressedBuffer(DecompressedStart), DecompressedChunk(0), DecompressedChunkSize
    Loop
    
    Decompression = DecompressedBuffer
End Function

Private Sub DecompressingTokenSequence(CompressedData() As Byte, DecompressedChunk() As Byte)
    Dim i As Integer
    Dim FlagByte As Byte
    Dim FlagBit As Byte
    Dim Index As Integer
    Dim DecompressedCurrent As Integer
    Dim CompressedCurrent As Integer
    Dim CompressedEnd As Integer
    Dim CopyToken As Long
    Dim Offset As Integer
    Dim Length As Integer
    
    ReDim DecompressedChunk(0 To 4098)
    CompressedEnd = UBound(CompressedData)
    DecompressedCurrent = 0
    CompressedCurrent = 0
    Index = 0
    
    Do
        If Index = 0 Then
            FlagByte = CompressedData(CompressedCurrent)
            CompressedCurrent = CompressedCurrent + 1
            If CompressedCurrent > CompressedEnd Then Exit Do
        End If
        
        FlagBit = ExtractFlagBit(Index, FlagByte)
        
        If FlagBit = 0 Then
            DecompressedChunk(DecompressedCurrent) = CompressedData(CompressedCurrent)
            DecompressedCurrent = DecompressedCurrent + 1
            CompressedCurrent = CompressedCurrent + 1
        Else
            CopyMemory CopyToken, CompressedData(CompressedCurrent), 2
            Call UnpackCopyToken(CopyToken, DecompressedCurrent, Offset, Length)
            For i = 1 To Length
                DecompressedChunk(DecompressedCurrent) = DecompressedChunk(DecompressedCurrent - Offset)
                DecompressedCurrent = DecompressedCurrent + 1
            Next
            CompressedCurrent = CompressedCurrent + 2
        End If
        
        Index = Index + 1
        If Index > 7 Then Index = 0
    Loop Until CompressedCurrent > CompressedEnd
    
    ReDim Preserve DecompressedChunk(0 To DecompressedCurrent - 1)
End Sub

Private Function ExtractFlagBit(Index As Integer, FlagByte As Byte) As Byte
    ExtractFlagBit = (FlagByte And (2 ^ Index)) / 2 ^ Index
End Function

Private Sub DecompressingRawChunk()
    ‘暂未遇到此种情况,有待日后遇到再调试
    Stop
End Sub

Private Function ExtractCompressedChunkSize(Header As Integer) As Integer
    ExtractCompressedChunkSize = (Header And &HFFF) + 1
End Function

Private Function ExtractCompressedChunkSignature(Header As Integer) As Integer
    Dim Temp As Integer
    Temp = Header And &H7000
    ExtractCompressedChunkSignature = Temp / &H1000
End Function

Private Function ExtractCompressedChunkFlag(Header As Integer) As Integer
    Dim Temp As Integer
    Temp = Header And &H8000
    ExtractCompressedChunkFlag = Temp / &H8000
End Function

Private Sub UnpackCopyToken(CopyToken As Long, DecompressedCurrent As Integer, Out_Offset As Integer, Out_Length As Integer)
    Dim bitCount As Integer
    
    bitCount = -Int(-Log(DecompressedCurrent) / Log(2))
    If bitCount < 4 Then bitCount = 4
    bitCount = 16 - bitCount
    Out_Length = CopyToken And (2 ^ bitCount - 1)
    Out_Offset = (CopyToken - Out_Length) / 2 ^ bitCount
    Out_Length = Out_Length + 3
    Out_Offset = Out_Offset + 1
End Sub