VBScript中的LZW压缩算法-优快云博客

介绍

本文向您展示如何在VBScript中实现LZW无损压缩算法。它也可以按原样或几乎按原样在VBA中使用。

https://zh.wikipedia.org/wiki/Lempel...%E2%80%93Welch LZW算法

LZW算法是一种压缩技术，不会造成数据丢失。它构建了动态压缩中使用的代码和值的字典。字典不与压缩文件一起存储，并且在压缩后将其丢弃。在解压缩期间，将从压缩的数据重建字典。

LZW算法通过以下方式起作用：

初始化字典以包含所有长度为一的字符串
在字典中找到与当前输入匹配的最长字符串
输出该匹配输入的字典代码
将输入中的下一个字符追加到匹配的输入字符串，并使用新代码将其添加为新的字典值
前往步骤2

守则及其使用方法

下面的代码是VBScript中LZW算法的示例实现，可轻松移植到VBA。函数是LZWCompress和LZWUncompress，并以文件路径为参数。

字典被初始化为8位值的完整范围，并且每个键使用16位。字典在达到65535个键后会重新初始化，我这样做是为了易于实现，即使这也意味着它没有尽可能压缩。

我对大型Access数据库的测试显示，压缩级别为86％，而使用7zip中的LZMA算法使用“超”级别压缩的压缩率为93％。

由于我一次读取1个字节的文件，因此该算法的执行速度也很慢。同样，这是由于易于实施。将大量文件读入内存而不是逐字节读取会更有效。

Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 8 
Function LZWCompress(strPath)
    Dim oFS, oFRead, oFWrite, oDict, strNext, strCurrent, intMaxCode, i 
    Set oDict = CreateObject("Scripting.Dictionary")
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set oFRead = oFS.OpenTextFile(strPath, ForReading)
    Set oFWrite = oFS.OpenTextFile(strPath & ".lzw", ForWriting, True)
    Set oFS = Nothing
    intMaxCode = 255
    strCurrent = oFRead.Read(1) 
    For i = 0 To 255
        oDict.Add Chr(i), i
    Next 
    Do Until oFRead.AtEndOfStream
        strNext = oFRead.Read(1) 
        If oDict.Exists(strCurrent & strNext) Then
            strCurrent = strCurrent & strNext
        Else
            oFWrite.Write(Chr(CByte(oDict.Item(strCurrent) \ 256)) & Chr(CByte(oDict.Item(strCurrent) Mod 256))) 
            intMaxCode = intMaxCode + 1
            oDict.Add strCurrent & strNext, intMaxCode
            strCurrent = strNext 
            If intMaxCode = 65535 Then
                intMaxCode = 255
                oDict.RemoveAll 
                For i = 0 To 255
                    oDict.Add Chr(i), i
                Next
            End If
        End If
    Loop 
    oFWrite.Write(Chr(CByte(oDict.Item(strCurrent) \ 256)) & Chr(CByte(oDict.Item(strCurrent) Mod 256))) 
    oFRead.Close
    oFWrite.Close
    Set oFRead = Nothing
    Set oFWrite = Nothing
    Set oDict = Nothing
End Function 
Function LZWUncompress(strPath)
    Dim oFS, oFRead, oFWrite, oDict, intNext, intCurrent, intMaxCode, i, strNext 
    Set oDict = CreateObject("Scripting.Dictionary")
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set oFRead = oFS.OpenTextFile(strPath, ForReading)
    Set oFWrite = oFS.OpenTextFile(strPath & ".unc", ForWriting, True)
    Set oFS = Nothing
    intMaxCode = 255
    strNext = oFRead.Read(2)
    intCurrent = 0
    For i = 1 To Len(strNext)
        intCurrent = intCurrent + 256 ^ (Len(strNext) - i) * Asc(Mid(strNext, i, 1))
    Next 
    For i = 0 To 255
        oDict.Add i, Chr(i)
    Next 
    Do Until oFRead.AtEndOfStream
        oFWrite.Write(oDict.Item(intCurrent))
        intMaxCode = intMaxCode + 1 
        strNext = oFRead.Read(2)
        intNext = 0
        For i = 1 To Len(strNext)
            intNext = intNext + 256 ^ (Len(strNext) - i) * Asc(Mid(strNext, i, 1))
        Next 
        If oDict.Exists(intNext) Then
            oDict.Add intMaxCode, oDict.Item(intCurrent) & Left(oDict.Item(intNext), 1)
        Else
            oDict.Add intMaxCode, oDict.Item(intCurrent) & Left(oDict.Item(intCurrent), 1)
        End If 
        If intMaxCode = 65535 Then
            intMaxCode = 255
            oDict.RemoveAll 
            For i = 0 To 255
                oDict.Add i, Chr(i)
            Next
        End If 
        intCurrent = intNext
    Loop
    oFWrite.Write(oDict.Item(intCurrent)) 
    oFRead.Close
    oFWrite.Close
    Set oFRead = Nothing
    Set oFWrite = Nothing
    Set oDict = Nothing
End Function