当我们编写程序时，会常常遇到程序信息内容更新的问题，对于小的文件更新，可以提供给客户自己到网络上下载，但对于大且多的文件，由于网络的原因，通过下载却又不实际，动辄是更新不完整，影响了程序的运行。当时我编写“商务娱乐频道系统”时，也遇到了这样的问题，对于大型的视频及图片文件，我考虑到了使用压缩包提供给客户，但是通过使用压缩程序却不能将我的文件按要求进行解压到其他相应的目录，那时我想到了何不自己制作压缩与解压缩程序呢。解压时将文件解压到程序所要的位置。
为了这个项目，我仔细的研究了VB的安装程序，原来VB是通过系统所自带的资源来进行压缩与解压缩，如MakeCab.exe、vb6stkit.dll等。
其实真真做起来还是挺简单的，就是调用几个API函数便可以搞定。近日，闲着有空，翻看自己的旧程序，故决定将该程序整理出来，与大家共享。
下面是具体的程序编写模块，首先你需要建立一个工程（名称由你自己确定了）：
1. 添加两个模块，在这里我给它们分别命名为modAPI、modMain；
2. 添加三个窗体，在这里我给它们分别命名为frmMain、frmLogin、frmAddInfo；
3. 以下是各个模块的源代码内容，请先保存该工程，并且关闭，然后转到该工程的文件夹下，按下面的提示进行源代码拷贝；
用记事本打开frmMain.frm文件，copy以下内容到其中：
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "信息文件更新"
ClientHeight = 5385
ClientLeft = 45
ClientTop = 330
ClientWidth = 8550
ControlBox = 0 'False
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5385
ScaleWidth = 8550
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdOk
Caption = "导出更新列表"
Height = 375
Index = 3
Left = 5385
TabIndex = 6
Top = 4980
Width = 1545
End
Begin VB.CommandButton cmdOk
Caption = "关 闭"
Height = 375
Index = 2
Left = 7620
TabIndex = 5
Top = 4980
Width = 885
End
Begin VB.CommandButton cmdOk
Caption = "打 包"
Height = 375
Index = 1
Left = 3810
TabIndex = 1
Top = 4980
Width = 885
End
Begin VB.CommandButton cmdOk
Caption = "展 开"
Height = 375
Index = 0
Left = 0
TabIndex = 0
Top = 4980
Width = 885
End
Begin MSComctlLib.ListView lstInfo
Height = 4275
Left = 0
TabIndex = 2
Top = 330
Width = 8505
_ExtentX = 15002
_ExtentY = 7541
View = 3
Arrange = 1
LabelEdit = 1
MultiSelect = -1 'True
LabelWrap = -1 'True
HideSelection = 0 'False
FullRowSelect = -1 'True
GridLines = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 3
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "序号"
Object.Width = 1235
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "压缩包文件"
Object.Width = 6068
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "目标信息"
Object.Width = 7832
EndProperty
End
Begin MSComDlg.CommonDialog comdInfo
Left = 0
Top = 360
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
MaxFileSize = 30000
End
Begin MSComctlLib.ProgressBar PGBar
Height = 345
Left = 30
TabIndex = 4
Top = 4620
Width = 8505
_ExtentX = 15002
_ExtentY = 609
_Version = 393216
Appearance = 0
Scrolling = 1
End
Begin VB.Label lblAbout
BackStyle = 0 'Transparent
Caption = "关于本程序..."
Height = 255
Left = 7260
TabIndex = 8
Top = 60
Width = 1215
End
Begin VB.Label lblInfo
AutoSize = -1 'True
Caption = "请等待，正在创建包信息文件..."
Height = 180
Index = 1
Left = 30
TabIndex = 7
Top = 4740
Width = 4980
End
Begin VB.Label lblInfo
AutoSize = -1 'True
Caption = "展开打包信息更新列表："
Height = 180
Index = 0
Left = 30
TabIndex = 3
Top = 30
Width = 1980
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ==============================================
' 信息打包与展开 (主窗体模块，即展开窗体)
'
' 功能 :利用系统所存在的资源自作压缩与解压缩程序
'
' 作 者 :谢家峰
' 整理日期 :2004-08-08
' Email :douhapy@sina.com
'
' ==============================================
'
Option Explicit
Private Declare Function ExtractFileFromCab Lib "vb6stkit.dll" _
(ByVal Cab As String, ByVal File As String, ByVal dest As String, _
ByVal iCab As Long, ByVal sSrc As String) As Long
'说明：
'cab 为系统安装目录下的压缩包
'file 为压缩包内的某文件名称（需在该文件名前加“@”字符）
'dest 为压缩包内的某文件解压后的完全路径名
'icab 为压缩包的数目
'ssrc 临时文件夹，一个有效的文件夹路径
Dim s_FileNames() As String '源文件名（不含路径）
Dim d_FileNames() As String '目标文件名（含路径）
Dim cab_FileName As String '包文件名
Private Sub cmdOK_Click(Index As Integer)
Dim FileNum As Long
Dim i As Long
Dim j As Long
Dim FileName As String
Select Case Index
Case 0
FileName = App.Path & "\更新.ini"
'查找包文件信息
s_FileNames = GetFiles(App.Path & "\*.cab_")
If UBound(s_FileNames) = 0 Then
MsgBox "当前目录下没找到“商务频道系统文件更新”包文件！", , App.EXEName
Exit Sub
End If
If UBound(s_FileNames) > 1 Then
With comdInfo
.Filter = "商务频道系统文件更新包|*.cab_|"
.DialogTitle = "请指定“商务频道系统文件更新”包的位置"
.InitDir = App.Path
.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
.FileName = App.Path & "\" & s_FileNames(1)
On Error GoTo Errfind
.ShowOpen
cab_FileName = Trim(Right(.FileName, Len(.FileName) - Len(App.Path & "\")))
On Error GoTo 0
End With
Else
cab_FileName = s_FileNames(1)
End If
Screen.MousePointer = 11
PGBar.Visible = False
lblInfo(1).Visible = True
DoEvents
'将当前包复制到系统安装文件夹下
If FileExists(WindowsPath & cab_FileName) Then Kill WindowsPath & cab_FileName
FileCopy App.Path & "\" & cab_FileName, WindowsPath & cab_FileName
'转换包路径信息（为系统安装目录下的文件）
cab_FileName = WindowsPath & cab_FileName
SetAttr cab_FileName, vbNormal
'获得“更新.ini”文件
j = ExtractFileFromCab(cab_FileName, "@更新.ini", FileName, 1, App.Path & "\")
SetAttr FileName, vbNormal
lblInfo(1).Visible = False
PGBar.Visible = True
Screen.MousePointer = 1
DoEvents
If j = 0 Then
MsgBox "该压缩包信息不完整，或不是“商务频道系统文件更新”包！" & vbCrLf & vbCrLf & "解压没完成,请索取最新的更新包！", , App.EXEName
'删除系统安装目录下的复制包
Kill cab_FileName
Exit Sub
Else
SetAttr FileName, vbNormal
End If
Screen.MousePointer = 11
'解压信息
FileNum = CLng(CLng(ReadIniFile(FileName, "文件数目", "FileNum")))
ReDim s_FileNames(FileNum)
ReDim d_FileNames(FileNum)
'其中s_FileNames的最后一个数据为播放信息文件
For i = 1 To FileNum
s_FileNames(i - 1) = ReadIniFile(FileName, "源文件信息", "File" & i)
s_FileNames(i - 1) = GetFileName(s_FileNames(i - 1))
d_FileNames(i - 1) = ReadIniFile(FileName, "目标文件信息", "File" & i)
DoEvents
Next
lstInfo.ListItems.Clear
PGBar.Min = 1
PGBar.Max = FileNum + 1
For i = 1 To FileNum
DoEvents
'建立文件夹
CreateFloder d_FileNames(i - 1)
'解压文件
If FileExists(d_FileNames(i - 1)) Then SetAttr d_FileNames(i - 1), vbNormal
j = ExtractFileFromCab(cab_FileName, "@" & s_FileNames(i - 1), d_FileNames(i - 1), 1, App.Path & "\")
If j = 0 Then
MsgBox "该压缩包信息不完整，或不是“商务频道系统文件更新”包！" & vbCrLf & vbCrLf & "解压没完成,请索取最新的更新包！", , App.EXEName
lstInfo.ListItems.Clear
PGBar.Min = 0
PGBar.Value = 0
Screen.MousePointer = 1
Exit Sub
End If
PGBar.Value = i
DoEvents
lstvInfo_Add lstInfo, 3, False, lstInfo.ListItems.count + 1, s_FileNames(i - 1), d_FileNames(i - 1)
Next
'删除系统安装目录下的复制包
Kill cab_FileName
Kill FileName
PGBar.Value = FileNum + 1
MsgBox "解压缩完成，系统更新完成，谢谢使用！", , App.EXEName
PGBar.Min = 0
PGBar.Value = 0
Case 1 ' 执行信息打包
lstInfo.ListItems.Clear
frmLogin.Show 1, Me
Case 2
Unload Me
Case 3
If lstInfo.ListItems.count = 0 Then MsgBox "无信息可供导出！", , App.EXEName: Exit Sub
With frmMain.comdInfo
.Filter = "更新列表信息|*.txt"
.DialogTitle = "导出包列表信息文件"
.InitDir = CurDir()
.Flags = cdlOFNHideReadOnly
.FileName = "更新列表.txt"
On Error GoTo ErrLab
.ShowSave
FileName = .FileName
If FileExists(FileName) Then
SetAttr FileName, vbNormal
Kill FileName
End If
'导出信息
With lstInfo
WritePrivateProfileString "文件数目", "FileNum", CStr(.ListItems.count), FileName
For i = 1 To .ListItems.count
WritePrivateProfileString "压缩包文件信息", "File" & i, .ListItems(i).SubItems(1), FileName
WritePrivateProfileString "目标文件信息", "File" & i, .ListItems(i).SubItems(2), FileName
Next
End With
End With
MsgBox "信息列表被导出在“" & FileName & "”文件中！", , App.EXEName
Case Else
End Select
Screen.MousePointer = 1
Exit Sub
ErrLab:
If Err.Number = 32755 Then
'解压文件
d_FileNames(FileNum) = App.Path & "\" & s_FileNames(FileNum)
If FileExists(d_FileNames(i - 1)) Then SetAttr d_FileNames(FileNum), vbNormal
ExtractFileFromCab cab_FileName, "@" & s_FileNames(FileNum), d_FileNames(FileNum), 1, App.Path & "\"
SetAttr d_FileNames(FileNum), vbNormal
PGBar.Value = FileNum + 1
lstvInfo_Add lstInfo, 3, False, lstInfo.ListItems.count + 1, s_FileNames(FileNum), App.Path & "\" & s_FileNames(FileNum)
'删除系统安装目录下的复制包
If FileExists(cab_FileName) Then Kill cab_FileName
Kill FileName
MsgBox "您取消了指定用户信息的位置，该用户信息缺省被放在“" & d_FileNames(FileNum) & "”！" _
& vbCrLf & vbCrLf & "解压缩完成，系统更新完成，谢谢使用！", , App.EXEName
PGBar.Min = 0
PGBar.Value = 0
Else
Err.Raise Err.Number, , Err.Description
End If
Screen.MousePointer = 1
Exit Sub
Errfind:
If Err.Number = 32755 Then
Else
Err.Raise Err.Number, , Err.Description
End If
Screen.MousePointer = 1
Exit Sub
End Sub
Private Sub lblAbout_Click()
lblAbout.BorderStyle = 1
frmAbout.Show 1, Me
End Sub
Private Sub lstInfo_ItemClick(ByVal Item As MSComctlLib.ListItem)
If Not (Item Is Nothing) Then
lstInfo.ToolTipText = "[目标信息] " & Item.ListSubItems(2)
End If
End Sub
