ziparchive文件处理库

标准dll,主要包含压缩\全解压\提取单个文件\读取Zipfile文本内容等功能。包含32位和64位。使用参考下面vba代码:

#If VBA7 Then
Declare PtrSafe Sub ZipInit Lib "ZipArchive.dll" ()
Declare PtrSafe Function ZipDirectory Lib "ZipArchive.dll" (ByVal ziparchive As LongPtr, ByVal directory As LongPtr) As Boolean
Declare PtrSafe Sub OpenZipFile Lib "ZipArchive.dll" (ByVal ziparchive As LongPtr)
Declare PtrSafe Function ZipFileCount Lib "ZipArchive.dll" () As Long
Declare PtrSafe Function IsValidZip Lib "ZipArchive.dll" (ByVal ziparchive As LongPtr) As Boolean
Declare PtrSafe Function UnCompressZipFile Lib "ZipArchive.dll" (ByVal desdirectory As LongPtr) As Boolean
Declare PtrSafe Sub GetFileName Lib "ZipArchive.dll" (ByVal index As Long, ByRef filename As LongPtr)
Declare PtrSafe Sub ReadTextFile Lib "ZipArchive.dll" (ByVal Filenameinzip As LongPtr, ByRef textResult As LongPtr, ByRef Length As Long)
Declare PtrSafe Sub ExtractFile Lib "ZipArchive.dll" (ByVal Filenameinzip As LongPtr, ByVal Despath As LongPtr)
Declare PtrSafe Function GetEntryIndex Lib "ZipArchive.dll" (ByVal Filenameinzip As LongPtr) As Long
Declare PtrSafe Sub CloseZipFile Lib "ZipArchive.dll" ()
Declare PtrSafe Sub ZipFree Lib "ZipArchive.dll" ()
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Declare PtrSafe Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
#Else
Enum LongPtr
[_]
End Enum

Declare Sub ZipInit Lib "ZipArchive.dll" ()
Declare Function ZipDirectory Lib "ZipArchive.dll" (ByVal ziparchive As LongPtr, ByVal directory As LongPtr) As Boolean
Declare Sub OpenZipFile Lib "ZipArchive.dll" (ByVal ziparchive As LongPtr)
Declare Function ZipFileCount Lib "ZipArchive.dll" () As Long
Declare Function IsValidZip Lib "ZipArchive.dll" (ByVal ziparchive As LongPtr) As Boolean
Declare Function UnCompressZipFile Lib "ZipArchive.dll" (ByVal desdirectory As LongPtr) As Boolean
Declare Sub GetFileName Lib "ZipArchive.dll" (ByVal index As Long, ByRef filename As LongPtr)
Declare Sub ReadTextFile Lib "ZipArchive.dll" (ByVal Filenameinzip As LongPtr, ByRef textResult As LongPtr)
Declare Sub ExtractFile Lib "ZipArchive.dll" (ByVal Filenameinzip As LongPtr, ByVal Despath As LongPtr)
Declare Function GetEntryIndex Lib "ZipArchive.dll" (ByVal Filenameinzip As LongPtr) As Long
Declare Sub CloseZipFile Lib "ZipArchive.dll" ()
Declare Sub ZipFree Lib "ZipArchive.dll" ()
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As LongPtr) As Long
#End If
Private Function PtrToStr(ByVal ptr As LongPtr) As Byte()
    Dim buffer() As Byte
    Dim n As Long
    n = lstrlenW(ptr) * 2
    ReDim buffer(0 To n - 1)
    ' 复制内存到安全的字节数组
    CopyMemory buffer(0), ByVal ptr, n
    ' 将字节数组转换为字符串
    PtrToStr = buffer()
End Function

Private Function bytePtrToStr(ByVal ptr As LongPtr, ByVal bytelen As Long) As Byte() '这个函数给ReadTextFile读取压缩包内容读取。因为直接字符串会涉及到文件编码问题。所以把编码问题给vba来处理
    Dim buffer() As Byte
    Dim n As Long
    n = bytelen
    ReDim buffer(0 To n - 1)
    ' 复制内存到安全的字节数组
    CopyMemory buffer(0), ByVal ptr, n
    ' 指针数组转化为字节数组
   bytePtrToStr = buffer()
End Function

Sub zipfiletest() '读取xlsx里的压缩文件列表和获取xml内容
Dim cc As Long, i&, fn As LongPtr, ZipFilePath$, Filenameinzip As LongPtr, unzipFilepath$, Drawingxml$, Fileindex As Long, szText As LongPtr, Textbuffer() As Byte, sztxtLen As Long
ChDrive ThisWorkbook.FullName
#If Win64 Then
    ChDir ThisWorkbook.Path & "\win64"
#Else
    ChDir ThisWorkbook.Path & "\win32"
#End If

ZipFilePath = ThisWorkbook.Path & "\测试文件.xlsx"
If Len(Dir(ZipFilePath)) = 0 Then MsgBox "xlsx文件不存在": Exit Sub
ZipInit
If IsValidZip(StrPtr(ZipFilePath)) Then Debug.Print "这是一个有效的zip压缩文档" Else GoTo label1
'测试压缩一个文件夹下的所有内容 zipdirectory
ZipDirectory StrPtr(ThisWorkbook.Path & "\结果.zip"), StrPtr(ThisWorkbook.Path & "\win32") '第一参数：要生成的压缩文件.第二参数：要进行打包的文件夹
OpenZipFile StrPtr(ZipFilePath)
unzipFilepath = ThisWorkbook.Path & "\temp"
If Len(Dir(unzipFilepath)) Then MkDir unzipFilepath
UnCompressZipFile StrPtr(unzipFilepath) 'open压缩文档后再解压,只需要解压的路径
Debug.Print "去目录下的temp文件夹检查是否有解压"
cc = ZipFileCount
For i = 0 To cc - 1
    GetFileName i, fn '获取压缩目录文件名指针

    Debug.Print PtrToStr(fn) '指针转化为字符串并打印出来
Next i

    Filenameinzip = StrPtr("xl/drawings/drawing1.xml")
    Fileindex = GetEntryIndex(Filenameinzip)
    If Fileindex = -1 Then MsgBox "所要访问的压缩包里的文件不存在": GoTo label2:
    ReadTextFile Filenameinzip, szText, sztxtLen '读取xml文件内容指针
     '内容指针转化为字符串，xml的编码为utf-8
    Textbuffer() = bytePtrToStr(szText, sztxtLen)
    Drawingxml = zm(Textbuffer(), "UTF-8")
    Debug.Print Drawingxml '打印内容
    '尝试解压图片文件出来
    ExtractFile StrPtr("xl/media/image1.png"), StrPtr(ThisWorkbook.Path)
label2:
    CloseZipFile
label1:
    ZipFree
End Sub
Function zm(ByRef arr() As Byte, ByVal encoding As String) As String
Dim Stream As Object
Set Stream = CreateObject("ADODB.Stream")
With Stream
    .Type = 1
    .Mode = 3
    .Open
    .Write arr()
    .Position = 0
    .Type = 2
    .Charset = encoding
    zm = .ReadText
    .Close
End With
 Set Stream = Nothing
End Function

vb里面只需要利用技巧

Enum LongPtr
[_]
End Enum

我们就可以在vb6里面使用LongPtr,这样就可以直接使用vba里的代码而不用修改。

完整的库和demo可以通过下面的附件下载以作参考。

Views: 72