'说明：在VB下运行会出现“DLL 的调用约定错误（错误 49）”
'但编译后再运行EXE则运行正常
'zlib1.dll不用注册或复制到系统目录下，程序首先会在当前目录下查找该文件,有则使用它。
'VB的Open语句打开文件，第1个字节位于1，而WinHex等十六进制编辑器第1个字节位于0
'---------------------------------------------------------------------
Option Explicit
Dim strFileName As String
Dim lngFileCount As Long '打包的文件总数
Dim strFileList() As String '保存文件的名字路径 列表
Dim lngFileStartOffsetList() As Long '保存文件起始偏移 列表
Dim lngFileOriginSizeList() As Long '保存文件的原始大小 列表
Dim lngFileSizeList() As Long '保存文件的大小 列表
Dim lngFileListPos As Long '文件列表区的偏移地址
Dim lngFileListSize As Long '文件列表区的大小
Dim strPkgDirName As String
Const pkgFileHead As Long = &H64 '文件头 64 00 00 00
Private Function ReadPkgFile(strFileName As String) As Long
'读取P文件
Dim lngTmp As Long '4字节
Dim intTmp As Integer '2字节
Dim bytFilePath() As Byte
Dim i As Long
i = 0
Open strFileName For Binary As #1
Get #1, , lngTmp '1 - 4
'判断文件头是否是p文件
If lngTmp <> pkgFileHead Then Exit Function
'获取打包的文件个数
Get #1, , lngFileCount '5 - 8
ReDim strFileList(lngFileCount - 1)
ReDim lngFileStartOffsetList(lngFileCount - 1)
ReDim lngFileSizeList(lngFileCount - 1)
ReDim lngFileOriginSizeList(lngFileCount - 1)
'获取文件列表区的偏移地址
Get #1, , lngFileListPos '9 - 12
'获取文件列表区的大小
Get #1, , lngFileListSize '13 - 16
'转到文件列表区的位置开始读写
Seek #1, lngFileListPos + 1
Do Until EOF(1)
Get #1, , intTmp '后面的文件路径名称的长度
ReDim bytFilePath(intTmp - 1)
Get #1, , bytFilePath '文件路径名称
strFileList(i) = StrConv(bytFilePath(), vbUnicode)
Get #1, , lngTmp '00 00 00 00，大概是起分隔作用吧
If lngTmp = 0 Then
'无需处理
End If
Get #1, , lngTmp '文件起始偏移地址
lngFileStartOffsetList(i) = lngTmp
Get #1, , lngTmp '原始文件大小
lngFileOriginSizeList(i) = lngTmp
Get #1, , lngTmp '文件结束偏移地址
lngFileSizeList(i) = lngTmp
'一个文件记录结束
i = i + 1
If Seek(1) >= lngFileListPos + lngFileListSize Then '偏移+ 1，大小 -1 ，正好抵消
Exit Do
End If
Loop
Close #1
'返回值就是打包的文件个数
ReadPkgFile = i
End Function
Private Function GetSingleFileData(ByVal No As Long) As Byte()
Dim bytFileData() As Byte
Dim lngFileSize As Long
ReDim bytFileData(lngFileSizeList(No) - 1)
Open strFileName For Binary As #1
'转到文件列表区的位置开始读写
Seek #1, lngFileStartOffsetList(No) + 1
Get #1, , bytFileData
Close #1
GetSingleFileData = bytFileData
End Function
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub cmdOpen_Click()
'打开p文件
Dim i As Long
Dim lngFileCount As Long '打包的文件个数
CD.Filter = "Q文件(*.0.0)|*.0.0"
CD.ShowOpen
If CD.FileName = "" Then Exit Sub
strFileName = CD.FileName
lngFileCount = ReadPkgFile(strFileName)
List1.Clear
For i = 0 To (lngFileCount - 1)
List1.AddItem strFileList(i)
Next
End Sub
Private Function FileExist(ByRef inFile As String) As Boolean
On Error Resume Next
FileExist = CBool(FileLen(inFile) + 1)
End Function
Private Function FileToBuf(ByRef inFile As String, ByRef outBuf() As Byte) As Long
'读取二进制文件到字节数组
Dim FNum As Integer
Dim RetBuf() As Byte
If (Not FileExist(inFile)) Then Exit Function
FNum = FreeFile()
Open inFile For Binary Access Read Lock Write As #FNum
ReDim RetBuf(0 To (LOF(FNum) - 1)) As Byte
Get #FNum, , RetBuf()
Close #FNum
outBuf = RetBuf
FileToBuf = UBound(RetBuf) + 1
End Function
Private Sub SaveFile(ByRef bytData() As Byte, strFile As String)
'把字节数组写入二进制文件保存
Open strFile For Binary Access Write As #1
Put #1, , bytData()
Close #1
End Sub
Private Sub Log(strText As String)
'输出日志到文件
Open App.Path & "\log.txt" For Append As #1
Print #1, strText
Close #1
End Sub
Private Function CompressBytes(ByRef Bytes() As Byte, ByRef outBuf() As Byte) As Boolean
'压缩 二进制文件的字节数组 到 输出字节数组
Dim CompressBuf() As Byte
Dim CompressLen As Long
Dim RetVal As Long
CompressLen = compressBound(UBound(Bytes) + 1)
ReDim CompressBuf(0 To (CompressLen - 1)) As Byte
RetVal = compress(CompressBuf(0), CompressLen, Bytes(0), UBound(Bytes) + 1)
If (RetVal = Z_OK) Then
'成功压缩后，CompressLen会变成压缩后数据的真实大小
ReDim Preserve CompressBuf(0 To (CompressLen - 1)) '把多余的字节去掉
outBuf = CompressBuf
CompressBytes = True
Else
CompressBytes = False
End If
End Function
Private Function UnCompressBytes(ByRef Bytes() As Byte, ByRef OriginalSize As Long) As Byte()
'解压 压缩文件的字节数组 到 输出字节数组
Dim DecompressBuf() As Byte
Dim DecompressLen As Long
Dim RetVal As Long
DecompressLen = OriginalSize
ReDim DecompressBuf(0 To (DecompressLen - 1)) As Byte '注意这里分配缓冲区一定要足够大
RetVal = uncompress(DecompressBuf(0), DecompressLen, Bytes(0), UBound(Bytes) + 1)
' MsgBox RetVal
UnCompressBytes = DecompressBuf
End Function
Private Sub cmdSaveOriginFile_Click()
Dim i As Long
strPkgDirName = Trim$(txtPkgDirName.Text)
If Dir$(App.Path & "\" & strPkgDirName, vbDirectory) = "" Then
MkDir App.Path & "\" & strPkgDirName
End If
' 如果一个文件项被选中，那么将它保存到文件。
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
Call MakeDirectory(App.Path & "\" & strPkgDirName & "\", GetPath(strFileList(i)))
Call SaveFile(GetSingleFileData(i), App.Path & "\" & strPkgDirName & "\" & strFileList(i))
End If
Next i
MsgBox "保存文件成功!", vbInformation
End Sub
Private Sub cmdSaveUnComFile_Click()
Dim i As Long
Dim bytData() As Byte
Dim bytUnComData() As Byte
Dim Ret As Boolean
Dim strMsg As String
strPkgDirName = Trim$(txtPkgDirName.Text)
If Dir$(App.Path & "\" & strPkgDirName, vbDirectory) = "" Then
MkDir App.Path & "\" & strPkgDirName
End If
' 如果一个文件项被选中，那么将它保存到文件。
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
Call MakeDirectory(App.Path & "\" & strPkgDirName & "\", GetPath(strFileList(i)))
bytData = GetSingleFileData(i)
'---------------------------------------------------------------------------------
Dim DecompressBuf() As Byte
Dim DecompressLen As Long
Dim RetVal As Long
'这里假设并不知道原文件的大小，按照一般的压缩率计算，不会小于10%，就按照压缩文件大小的10倍来算
DecompressLen = lngFileOriginSizeList(i)
ReDim DecompressBuf(0 To (DecompressLen - 1)) As Byte '注意这里分配缓冲区一定要足够大
RetVal = uncompress(DecompressBuf(0), DecompressLen, bytData(0), UBound(bytData) + 1)
Call SaveFile(DecompressBuf(), App.Path & "\" & strPkgDirName & "\" & strFileList(i))
'---------------------------------------------------------------------------------
End If
Next
MsgBox "保存解出的文件成功！", vbInformation
End Sub
Private Sub List1_Click()
'点击文件名，显示文件信息
lblCount.Caption = CStr(List1.ListIndex + 1) & "/" & List1.ListCount
txtStartOffset.Text = Hex$(lngFileStartOffsetList(List1.ListIndex))
txtEndOffset.Text = Hex$(lngFileSizeList(List1.ListIndex))
txtOriginSize.Text = Hex$(lngFileOriginSizeList(List1.ListIndex))
End Sub
Private Function GetPath(strFilePath As String) As String
'根据完整文件路径获取相对目录，即去掉\符号和文件名
Dim intPos As Integer
intPos = InStrRev(strFilePath, "\")
GetPath = Mid$(strFilePath, 1, intPos - 1)
End Function
Private Sub MakeDirectory(strMainDir As String, strDirPath As String)
'根据一个相对目录路径名，判断目录是否存在，不存在则建立
'参数：
'strMainDir - 完整目录名后面带有\符号，在这个目录下检查strDirPath的文件夹是否存在
'strDirPath - 目录路径名，后面不带有\符号
Dim strPart() As String
Dim i As Integer
Dim strDir As String
strPart = Split(strDirPath, "\")
For i = 0 To UBound(strPart)
strDir = strDir & strPart(i) & "\"
If Dir$(strMainDir & strDir, vbDirectory) = "" Then
MkDir strMainDir & strDir
End If
Next
End Sub
谁能全部翻译出来我，留下你的QQ 赏300大洋
