用VB6.0自制压缩与解压缩程序-星旺坡

管理首页

用VB6.0自制压缩与解压缩程序
当我们编写程序时，会常常遇到程序信息内容更新的问题，对于小的文件更新，可以提供给客户自己到网络上下载，但对于大且多的文件，由于网络的原因，通过下载却又不实际，动辄是更新不完整，影响了程序的运行。当时我编写“商务娱乐频道系统”时，也遇到了这样的问题，对于大型的视频及图片文件，我考虑到了使用压缩包提供给客户，但是通过使用压缩程序却不能将我的文件按要求进行解压到其他相应的目录，那时我想到了何不自己制作压缩与解压缩程序呢。解压时将文件解压到程序所要的位置。

为了这个项目，我仔细的研究了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

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 = "商务
用记事本打开frmLogin.frm文件，copy以下内容到其中：

VERSION 5.00

Begin VB.Form frmLogin

BorderStyle = 3 'Fixed Dialog

Caption = "登录"

ClientHeight = 1545

ClientLeft = 2835

ClientTop = 3480

ClientWidth = 3750

Icon = "frmLogin.frx":0000

LinkTopic = "Form1"

LockControls = -1 'True

MaxButton = 0 'False

MinButton = 0 'False

ScaleHeight = 912.837

ScaleMode = 0 'User

ScaleWidth = 3521.047

ShowInTaskbar = 0 'False

StartUpPosition = 2 '屏幕中心

Begin VB.TextBox txtUserName

Height = 345

Left = 1290

TabIndex = 1

Text = "123"

Top = 135

Width = 2325

End

Begin VB.CommandButton cmdOK

Caption = "确定"

Default = -1 'True

Height = 390

Left = 495

TabIndex = 4

Top = 1020

Width = 1140

End

Begin VB.CommandButton cmdCancel

Cancel = -1 'True

Caption = "取消"

Height = 390

Left = 2100

TabIndex = 5

Top = 1020

Width = 1140

End

Begin VB.TextBox txtPassword

Height = 345

IMEMode = 3 'DISABLE

Left = 1290

PasswordChar = "*"

TabIndex = 3

Text = "123"

Top = 525

Width = 2325

End

Begin VB.Label lblLabels

Caption = "用户名称(&U):"

Height = 270

Index = 0

Left = 105

TabIndex = 0

Top = 150

Width = 1080

End

Begin VB.Label lblLabels

Caption = "密码(&P):"

Height = 270

Index = 1

Left = 105

TabIndex = 2

Top = 540

Width = 1080

End

Attribute VB_Name = "frmLogin"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Option Explicit

Public LoginSucceeded As Boolean

Private Sub cmdCancel_Click()

'设置全局变量为 false

'不提示失败的登录

LoginSucceeded = False

Unload Me

End Sub

Private Sub cmdOK_Click()

'检查正确的密码

If UCase(txtPassword) = "123" And UCase(txtUserName) = "123" Then

'将代码放在这里传递

'成功到 calling 函数

'设置全局变量时最容易的

LoginSucceeded = True

Unload Me

frmAddInfo.Show 1, frmMain

Else

MsgBox "无效的用户或密码密码，请重试!", , "登录"

txtPassword.SetFocus

SendKeys "{Home}+{End}"

End If

End Sub

用记事本打开frmAddInfo.frm文件，copy以下内容到其中：

VERSION 5.00

Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"

Begin VB.Form frmAddInfo

BorderStyle = 3 'Fixed Dialog

Caption = "信息打包"

ClientHeight = 5505

ClientLeft = 45

ClientTop = 330

ClientWidth = 8655

ControlBox = 0 'False

Icon = "frmAddInfo.frx":0000

LinkTopic = "Form1"

LockControls = -1 'True

MaxButton = 0 'False

MinButton = 0 'False

ScaleHeight = 5505

ScaleWidth = 8655

ShowInTaskbar = 0 'False

StartUpPosition = 1 '所有者中心

Begin VB.TextBox txtEditInfo

Height = 285

Index = 3

Left = 1530

TabIndex = 15

Tag = "商务频道系统文件更新"

Text = "商务频道系统文件更新"

Top = 3420

Width = 5535

End

Begin VB.CommandButton cmdok

Caption = "导入包列表"

Height = 375

Index = 2

Left = 3930

TabIndex = 14

Top = 5040

Width = 1245

End

Begin VB.CommandButton cmdok

Caption = "关闭"

Height = 375

Index = 3

Left = 5850

TabIndex = 8

Top = 5040

Width = 1245

End

Begin VB.CommandButton cmdok

Caption = "导出包列表"

Enabled = 0 'False

Height = 375

Index = 1

Left = 2010

TabIndex = 7

Top = 5040

Width = 1245

End

Begin VB.CommandButton cmdok

Caption = "信息打包"

Enabled = 0 'False

Height = 375

Index = 0

Left = 90

TabIndex = 6

Top = 5040

Width = 1245

End

Begin VB.Frame framInfo

Caption = "编辑命令"

Height = 2235

Index = 1

Left = 7110

TabIndex = 2

Top = 3270

Width = 1545

Begin VB.CommandButton cmdinfo

Caption = "删除精选项"

Enabled = 0 'False

Height = 345

Index = 1

Left = 60

TabIndex = 9

Top = 750

Width = 1425

End

Begin VB.CommandButton cmdinfo

Caption = "修改信息"

Enabled = 0 'False

Height = 345

Index = 2

Left = 60

TabIndex = 5

Top = 1280

Width = 1425

End

Begin VB.CommandButton cmdinfo

Caption = "添加信息"

Height = 345

Index = 3

Left = 60

TabIndex = 4

Top = 1800

Width = 1425

End

Begin VB.CommandButton cmdinfo

Caption = "清空列表"

Enabled = 0 'False

Height = 345

Index = 0

Left = 60

TabIndex = 3

Top = 240

Width = 1425

End

Begin VB.Frame framInfo

Caption = "编辑与察看"

Enabled = 0 'False

Height = 1005

Index = 0

Left = 60

TabIndex = 1

Tag = "编辑与察看"

Top = 3900

Width = 7035

Begin VB.TextBox txtEditInfo

Height = 285

Index = 1

Left = 870

TabIndex = 12

Top = 660

Width = 6105

End

Begin VB.TextBox txtEditInfo

Height = 285

Index = 0

Left = 870

TabIndex = 10

Top = 270

Width = 6105

End

Begin VB.Label Label1

AutoSize = -1 'True

Caption = "目标信息："

Height = 180

Index = 1

Left = 60

TabIndex = 13

Top = 660

Width = 900

End

Begin VB.Label Label1

AutoSize = -1 'True

Caption = "源信息："

Height = 180

Index = 0

Left = 90

TabIndex = 11

Top = 270

Width = 720

End

Begin MSComctlLib.ListView lstInfo

Height = 3165

Left = 60

TabIndex = 0

Top = 60

Width = 8565

_ExtentX = 15108

_ExtentY = 5583

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 VB.Label Label1

AutoSize = -1 'True

Caption = "信息打包名称："

Height = 180

Index = 2

Left = 60

TabIndex = 16

Top = 3480

Width = 1260

End

Attribute VB_Name = "frmAddInfo"

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

' --------------------------------------------

' 设置编辑信息框

' --------------------------------------------

Sub EditLstvInfo(ByVal Item As MSComctlLib.ListItem)

Dim i As Integer

If Item Is Nothing Then

For i = 0 To 1

txtEditInfo(i) = ""

framInfo(0) = framInfo(0).Tag

framInfo(0).Enabled = False

cmdinfo(0).Enabled = False

cmdinfo(1).Enabled = False

cmdinfo(2).Enabled = False

cmdinfo(2).Caption = "修改信息"

cmdOK(0).Enabled = False

cmdOK(1).Enabled = False

Exit Sub

End If

framInfo(0) = "第" & Item.text & "列" & framInfo(0).Tag

With Item

txtEditInfo(0) = .SubItems(1)

txtEditInfo(1) = .SubItems(2)

End With

framInfo(0).Enabled = True

cmdinfo(0).Enabled = True

cmdinfo(1).Enabled = True

cmdinfo(2).Enabled = True

cmdinfo(2).Tag = Item.Index

cmdinfo(2).Caption = "修改第" & cmdinfo(2).Tag & "行信息"

cmdOK(0).Enabled = True

cmdOK(1).Enabled = True

End Sub

' -------------------------------------------------------------

' ListView控件重新排序，且返回最后一个被精选的项，若没有返回0

' -------------------------------------------------------------

Function lstInfo_sort() As Long

Dim i, j As Long

j = 0

For i = 1 To lstInfo.ListItems.count

lstInfo.ListItems(i).text = i

If lstInfo.ListItems(i).Selected Then j = i

lstInfo_sort = j

End Function

' --------------------------------------------

'检索所添加的信息在ListView控件中是否有重复

' --------------------------------------------

Function Check_OverLap(infoname As String) As Boolean

Dim i As Long

With lstInfo.ListItems

For i = 1 To .count

If Trim(LCase(.Item(i).SubItems(1))) = Trim(LCase(infoname)) Then

Check_OverLap = True

Exit Function

Else

Check_OverLap = False

End If

End With

End Function

Private Sub cmdinfo_Click(Index As Integer)

Dim AddFileName() As String

Dim str As String

Dim Value As String

Dim i As Long

Dim j As Long

Dim selIndex() As Long

Select Case Index

Case 0 '清除列表

lstInfo.ListItems.Clear

EditLstvInfo lstInfo.SelectedItem '显示精选项

Case 1 '删除精选项

ReDim selIndex(0): Value = ""

For i = 1 To lstInfo.ListItems.count

If lstInfo.ListItems(i).Selected Then

ReDim Preserve selIndex(UBound(selIndex) + 1)

selIndex(UBound(selIndex)) = i

Value = Value & " " & i

End If

Value = MsgBox("你将删除序号为“" & Trim(Value) & "”的信息！" & vbCrLf & "确定要删除吗？", vbQuestion + vbOKCancel, "警告")

If Value = vbCancel Then

Exit Sub

Else

Screen.MousePointer = 11

For i = UBound(selIndex) To 1 Step -1

lstInfo.ListItems.Remove selIndex(i)

'重新排序

j = lstInfo_sort

If j = 0 And lstInfo.ListItems.count <> 0 Then lstInfo.ListItems(lstInfo.ListItems.count).Selected = True

On Error Resume Next

lstInfo.SelectedItem.EnsureVisible

EditLstvInfo lstInfo.SelectedItem '显示精选项

If lstInfo.ListItems.count = 0 Then cmdinfo(2).Enabled = False: cmdinfo(1).Enabled = False

Screen.MousePointer = 1

End If

Case 2 '修改信息

If Not FileExists(Trim(txtEditInfo(0))) Then

MsgBox "源信息文件不存在！"

Exit Sub

End If

If Trim(txtEditInfo(1)) = "" Then

MsgBox "目标信息路径不能为空！"

Exit Sub

End If

If UCase(GetExt(Trim(txtEditInfo(1)))) <> UCase(GetExt(Trim(txtEditInfo(0)))) Then

MsgBox "目标信息文件扩展名不对！"

Exit Sub

End If

If Not CBool(InStr(1, Trim(txtEditInfo(1)), "C:\", vbTextCompare)) And Not CBool(InStr(1, Trim(txtEditInfo(1)), "D:\", vbTextCompare)) Then

MsgBox "目标信息路径格式不对！"

Exit Sub

End If

With lstInfo.ListItems.Item(CLng(cmdinfo(2).Tag))

'是否添加重复的主信息

If Check_OverLap(Trim(txtEditInfo(1))) Then

If Trim(.SubItems(2)) = Trim(txtEditInfo(1)) Then

MsgBox "信息重复，请重新编辑该项信息！", vbInformation, "警告"

Exit Sub

End If

.SubItems(1) = Trim(txtEditInfo(0))

.SubItems(2) = Trim(txtEditInfo(1))

End With

Case 3 '添加信息

With frmMain.comdInfo

.Filter = "所有可用信息|*.JPG;*.JPEG;*.BMP;*.SWF;*.GIF;*.AVI;*.MPG;*.MPEG;*.DAT;*.inf;*.MP3;*.MID;*.WAV;*.RM|" & _

"静态图像(*.JPG;*.JPEG;*.BMP)|*.JPG;*.JPEG;*.BMP|" & _

"动态图像(*.SWF;*.GIF;*.AVI;*.MPG;*.MPEG;*.DAT;*.RM)|*.SWF;*.GIF;*.AVI;*.MPG;*.MPEG;*.DAT;*.RM|" & _

"音乐(*.MP3;*.MID;*.WAV)|*.MP3;*.MID;*.WAV"

.DialogTitle = "请选择信息"

.InitDir = CurDir()

.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly Or _

cdlOFNAllowMultiselect Or cdlOFNExplorer

.FileName = ""

On Error GoTo ErrLab

.ShowOpen

str = .FileName

AddFileName() = Split(str, vbNullChar)

'添加信息到列表

If UBound(AddFileName) = 0 Then '选择了一项信息

'不添加重复的主信息

If Not Check_OverLap(str) Then

lstvInfo_Add lstInfo, 3, False, lstInfo.ListItems.count + 1, str, str

End If

For i = 1 To UBound(AddFileName) '选择了多项信息

str = AddFileName(0) & "\" & AddFileName(i)

'不添加重复的主信息

If Not Check_OverLap(str) Then

lstvInfo_Add lstInfo, 3, False, lstInfo.ListItems.count + 1, str, str

End If

lstInfo.ListItems.Item(lstInfo.ListItems.count).Selected = True

EditLstvInfo lstInfo.SelectedItem '显示精选项

End With

Case Else

End Select

Exit Sub

ErrLab:

If Err.Number = 32755 Then

Exit Sub

Else

Err.Raise Err.Number, , Err.Des cription

Exit Sub

End If

End Sub

Private Sub cmdOK_Click(Index As Integer)

Dim resultat As Long

Dim resultat2 As Long

Dim res As Double

Dim startinfo As STARTUPINFO

Dim procinfo As PROCESS_INFORMATION

Dim secu As SECURITY_ATTRIBUTES

Dim i As Long

Dim blInfo As Boolean

Dim FileName As String

Dim str1 As String

Dim str2 As String

startinfo.cb = Len(startinfo)

secu.nLength = Len(secu)

If Trim("" & txtEditInfo(3)) = "" Then

txtEditInfo(3) = txtEditInfo(3).Tag

End If

Select Case Index

Case 0 '信息打包

' 检查包信息是否存在

If FileExists(App.Path & "\" & Trim(txtEditInfo(3)) & ".CAB_") Then

If MsgBox("当前目录下存在 “" & Trim(txtEditInfo(3)) & ".CAB_” 包文件,是否覆盖？", vbQuestion + vbYesNo) = vbYes Then

Kill App.Path & "\" & Trim(txtEditInfo(3)) & ".CAB_"

Else

Exit Sub

End If

Screen.MousePointer = 11

'生成安装列表信息

FileName = App.Path & "\更新.ini"

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

WritePrivateProfileString "打包名称", "BagName", "" & txtEditInfo(3), FileName

End With

'生成商务.DDF文件，指定打包信息

str1 = ".Option EXPLICIT" & vbCrLf & _

".Set Cabinet=off" & vbCrLf & _

".Set Compress=off" & vbCrLf & _

".Set MaxDiskSize = CDROM" & vbCrLf & _

".Set ReservePerCabinetSize = 6144" & vbCrLf & _

".Set DiskDirectoryTemplate=" & vbCrLf & _

".Set CompressionType = MSZIP" & vbCrLf & _

".Set CompressionLevel = 7" & vbCrLf & _

".Set CompressionMemory = 21" & vbCrLf & _

".Set CabinetNameTemplate =" & Chr(34) & Trim(txtEditInfo(3)) & ".CAB_" & Chr(34) & vbCrLf & _

".Set Cabinet=on" & vbCrLf & _

".Set Compress=on" & vbCrLf

For i = 1 To lstInfo.ListItems.count

str1 = str1 & Chr(34) & lstInfo.ListItems(i).SubItems(1) & Chr(34) & vbCrLf

str1 = str1 & Chr(34) & FileName & Chr(34) '追加展开列表信息到包中

WriteTextFileContents str1, App.Path & "\商务.DDF"

'启动打包程序

resultat = CreateProcess(vbNullString, WindowsSysPath & "\makecab.exe /f 商务.DDF", secu, secu, _

0, 0, 0, App.Path, startinfo, procinfo)

resultat2 = WaitForSingleObject(procinfo.hProcess, INFINITE)

resultat2 = CloseHandle(procinfo.hProcess)

DoEvents

'删除不必要的信息

If FileExists(App.Path & "\商务.DDF") Then Kill App.Path & "\商务.DDF"

If FileExists(App.Path & "\更新.ini") Then Kill App.Path & "\更新.ini"

If FileExists(App.Path & "\setup.inf") Then Kill App.Path & "\setup.inf"

If FileExists(App.Path & "\setup.rpt") Then Kill App.Path & "\setup.rpt"

DoEvents

MsgBox "压缩包已生成！返回主窗体通过“展开”按钮将相应的信息文件展开到相应的目录中！" & vbCrLf & _

"文件列表已被导出在“" & FileName & "”中，若要编辑当前的信息，请在打包窗体中提取该信息文件！", , App.EXEName

Screen.MousePointer = 1

Unload Me

Case 1 '导出包列表

With frmMain.comdInfo

.Filter = "更新列表信息|*.TLB"

.DialogTitle = "导出包列表信息文件"

.InitDir = CurDir()

.Flags = cdlOFNHideReadOnly

.FileName = txtEditInfo(3) & ".TLB"

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

WritePrivateProfileString "打包名称", "BagName", "" & txtEditInfo(3), FileName

End With

MsgBox "信息列表被导出在“" & FileName & "”文件中！", , App.EXEName

Case 2 '导入包列表

If lstInfo.ListItems.count <> 0 Then

resultat = MsgBox("要保存当前的更新列表信息吗？", vbQuestion + vbOKCancel, App.EXEName)

If resultat = vbOK Then

cmdOK_Click 1

End If

With frmMain.comdInfo

.Filter = "更新列表信息|*.TLB"

.DialogTitle = "选择导入包列表信息文件"

.InitDir = CurDir()

.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly

.FileName = txtEditInfo(3).Tag

On Error GoTo ErrLab

.ShowOpen

FileName = .FileName

On Error GoTo 0

'导入信息

With lstInfo

.ListItems.Clear

resultat = CLng(ReadIniFile(FileName, "文件数目", "FileNum"))

If resultat = 0 Then

MsgBox "文件“" & FileName & "”没有信息，或不正确！", , App.EXEName

Exit Sub

End If

txtEditInfo(3) = ReadIniFile(FileName, "打包名称", "BagName")

For i = 1 To resultat

'不添加重复的主信息

str1 = ReadIniFile(FileName, "源文件信息", "File" & i)

str2 = ReadIniFile(FileName, "目标文件信息", "File" & i)

lstvInfo_Add lstInfo, 3, False, lstInfo.ListItems.count + 1, str1, str2

.ListItems(i - 1).Selected = True

EditLstvInfo .SelectedItem

End With

Case 3 '关闭

Unload Me

End Select

Exit Sub

ErrLab:

If Err.Number = 32755 Then

Exit Sub

Else

Err.Raise Err.Number, , Err.Des cription

Exit Sub

End If

End Sub

Private Sub lstInfo_ItemClick(ByVal Item As MSComctlLib.ListItem)

EditLstvInfo Item

End Sub

Private Sub lstInfo_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

Dim ItemInfo As MSComctlLib.ListItem

Set ItemInfo = lstInfo.HitTest(x, y)

If Not (ItemInfo Is Nothing) Then

lstInfo.ToolTipText = "[第" & Trim(ItemInfo) & "列] 源信息：" & Trim(ItemInfo.SubItems(1)) & _

" 目标信息：" & Trim(ItemInfo.SubItems(2))

Else

lstInfo.ToolTipText = ""

End If

Set ItemInfo = Nothing

End Sub

Private Sub txtEditInfo_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)

txtEditInfo(Index).ToolTipText = Trim(txtEditInfo(Index))

End Sub

用记事本打开modMain.bas文件，copy以下内容到其中：

Attribute VB_Name = "modMain"

' ==============================================

' 信息打包与展开 (启动模块)

' 功能 :利用系统所存在的资源自作压缩与解压缩程序

' 作者 :谢家峰

' 整理日期 :2004-08-08

' Email :douhapy@sina.com

' ==============================================

Option Explicit

Public WindowsPath As String

Public WindowsSysPath As String

Sub Main()

Dim BootTrapPath As String

Dim SetupFilePath As String

Dim regExeFilePath As String

Dim regInfo() As String

Dim regStr() As String

Dim regFileName As String

Dim str As String

Dim resultat As Long

Dim resultat2 As Long

Dim res As Double

Dim startinfo As STARTUPINFO

Dim procinfo As PROCESS_INFORMATION

Dim secu As SECURITY_ATTRIBUTES

Dim i As Integer

If App.PrevInstance Then MsgBox "系统已启动!", , App.EXEName: End

'获得系统安装目录

WindowsPath = GetWindowsDir

WindowsSysPath = GetWindowsSysDir

Load frmMain

frmMain.Show

End Sub

用记事本打开modAPI.bas文件，copy以下内容到其中：

Attribute VB_Name = "modAPI"

' ==============================================

' 信息打包与展开 (所调用的API及通用函数模块)

' 功能 :利用系统所存在的资源自作压缩与解压缩程序

' 作者 :谢家峰

' 整理日期 :2004-08-08

' Email :douhapy@sina.com

' ==============================================

Option Explicit

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpbuffer As String, ByVal nSize As Long) As Long

Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpbuffer As String, ByVal nSize As Long) As Long

Public Const gstrSEP_DIR$ = "\"

Public Const gstrSEP_URLDIR$ = "/"

Public Const gintMAX_SIZE% = 255

Public Const INFINITE = &HFFFF

Public Type STARTUPINFO

cb As Long

lpReserved As String

lpDesktop As String

lpTitle As String

dwX As Long

dwY As Long

dwXSize As Long

dwYSize As Long

dwXCountChars As Long

dwYCountChars As Long

dwFillAttribute As Long

dwFlags As Long

wShowWindow As Integer

cbReserved2 As Integer

lpReserved2 As Long

hStdInput As Long

hStdOutput As Long

hStdError As Long

End Type

Public Type PROCESS_INFORMATION

hProcess As Long

hThread As Long

dwProcessId As Long

dwThreadId As Long

End Type

Public Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDes criptor As Long

bInheritHandle As Long

End Type

Function StripTerminator(ByVal strString As String) As String

Dim intZeroPos As Integer

intZeroPos = InStr(strString, Chr$(0))

If intZeroPos > 0 Then

StripTerminator = Left$(strString, intZeroPos - 1)

Else

StripTerminator = strString

End If

End Function

' -----------------------------------------------------------

' 给目录添加分割线

' -----------------------------------------------------------

Sub AddDirSep(strPathName As String)

If Right(Trim(strPathName), Len(gstrSEP_URLDIR)) <> gstrSEP_URLDIR And _

Right(Trim(strPathName), Len(gstrSEP_DIR)) <> gstrSEP_DIR Then

strPathName = RTrim$(strPathName) & gstrSEP_DIR

End If

End Sub

' -----------------------------------------------------------

' 调用API函数获得Windows的系统目录

' -----------------------------------------------------------

Function GetWindowsSysDir() As String

Dim strBuf As String

strBuf = Space$(gintMAX_SIZE)

If GetSystemDirectory(strBuf, gintMAX_SIZE) > 0 Then

strBuf = StripTerminator(strBuf)

AddDirSep strBuf

GetWindowsSysDir = strBuf

Else

GetWindowsSysDir = vbNullString

End If

End Function

' -----------------------------------------------------------

' 调用API函数获取Windows目录

' -----------------------------------------------------------

Function GetWindowsDir() As String

Dim strBuf As String

strBuf = Space$(gintMAX_SIZE)

If GetWindowsDirectory(strBuf, gintMAX_SIZE) > 0 Then

strBuf = StripTerminator$(strBuf)

AddDirSep strBuf

GetWindowsDir = strBuf

Else

GetWindowsDir = vbNullString

End If

End Function

' --------------------------------------

' 测试目录是否存在

' --------------------------------------

Public Function DirExists(Path As String) As Boolean

On Error Resume Next

'对于网络地址采用*.*形式

If InStr(Path, "\\") Then

DirExists = (Dir$(Path & "\*.*") <> "")

Else

DirExists = (Dir$(Path & "\nul") <> "")

End If

End Function

' --------------------------------------

' 建立文件夹(含多层结构)

' --------------------------------------

Public Sub CreateFloder(floder As String)

Dim i As Integer

Dim Path As String

Dim FloderStr() As String

On Error Resume Next

FloderStr = Split(floder, "\")

Path = FloderStr(0)

For i = 1 To UBound(FloderStr) - 1

Path = Path & "\" & FloderStr(i)

If Not DirExists(Path) Then

MkDir Path

End If

End Sub

' --------------------------------------

' 获得长文件名的短文件名

' --------------------------------------

Function GetShortFileName(FileName As String) As String

Dim str As String

str = String(LenB(FileName), Chr(0))

If GetShortPathName(FileName, str, LenB(FileName)) <> 0 Then

str = Left(str, InStr(str, vbNullChar) - 1)

If str = "" Then

GetShortFileName = FileName

Else

GetShortFileName = str

End If

Else

GetShortFileName = FileName

End If

End Function

' --------------------------------------

' 获得文件名

' --------------------------------------

Public Function GetFileName(fileNamePath As String) As String

Dim AuxVar() As String

AuxVar() = Split(fileNamePath, "\", , vbTextCompare)

GetFileName = AuxVar(UBound(AuxVar))

End Function

' --------------------------------------

' 获得文件的扩展名

' --------------------------------------

Public Function GetExt(FileName As String) As String

Dim AuxVar() As String

On Error Resume Next

AuxVar() = Split(FileName, "\", , vbTextCompare)

AuxVar() = Split(AuxVar(UBound(AuxVar)), ".", , vbTextCompare)

GetExt = AuxVar(UBound(AuxVar))

End Function

' --------------------------------------

' 测试文件是否存在(不能测试隐含文件和系统文件)

' --------------------------------------

Public Function FileExists(FileName As String) As Boolean

On Error Resume Next

FileExists = (Dir$(FileName) <> "")

End Function

' --------------------------------------

' 查找文件

' --------------------------------------

Function GetFiles(filespec As String, Optional Attributes As VbFileAttribute) As String()

Dim result() As String

Dim FileName As String, count As Long, path2 As String

Const ALLOC_CHUNK = 50

ReDim result(0 To ALLOC_CHUNK) As String

FileName = Dir$(filespec, Attributes)

Do While Len(FileName)

count = count + 1

If count > UBound(result) Then

ReDim Preserve result(0 To count + ALLOC_CHUNK) As String

End If

result(count) = FileName

FileName = Dir$

Loop

ReDim Preserve result(0 To count) As String

GetFiles = result

End Function

' --------------------------------------

' 转换字符串

' --------------------------------------

Public Function StringFromBuffer(buffer As String) As String

Dim nPos As Long

nPos = InStr(buffer, vbNullChar)

If nPos > 0 Then

StringFromBuffer = Left$(buffer, nPos - 1)

Else

StringFromBuffer = buffer

End If

End Function

' --------------------------------------

' 写内容到文本文件中

' --------------------------------------

Sub WriteTextFileContents(text As String, FileName As String, Optional AppendMode As Boolean)

Dim fnum As Integer, isOpen As Boolean

On Error GoTo Error_Handler

fnum = FreeFile()

If AppendMode Then

Open FileName For Append As #fnum

Else

Open FileName For Output As #fnum

End If

isOpen = True

Print #fnum, text

Error_Handler:

If isOpen Then Close #fnum

If Err Then Err.Raise Err.Number, , Err.Des cription

End Sub

' --------------------------------------

' 读信息到Ini文件中

' --------------------------------------

Public Function ReadIniFile(ByVal strIniFile As String, ByVal strSection As String, ByVal strKey As String) As String

Dim strBuffer As String * 255

If GetPrivateProfileString(strSection, strKey, vbNullString, strBuffer, 255, strIniFile) Then

ReadIniFile = StringFromBuffer(strBuffer)

End If

End Function

' --------------------------------------

' 添加信息到ListView控件中

' --------------------------------------

Sub lstvInfo_Add(LstVControl As ListView, InfoNum As Integer, SelectedFlag As Boolean, ParamArray InfoStr())

Dim i As Integer

With LstVControl

.ListItems.Add , , Trim(InfoStr(0))

If SelectedFlag Then

.ListItems(.ListItems.count).Selected = True

Else

.ListItems(.ListItems.count).Selected = False

End If

For i = 2 To InfoNum

.ListItems(.ListItems.count).ListSubItems.Add , , Trim(InfoStr(i - 1))

.ListItems(.ListItems.count).EnsureVisible

End With

End Sub

自此，代码Copy完成，这时你再打开工程，编译运行。

1. 信息打包：在frmMain窗体中点击“打包”，直至打开frmAddInfo窗体，在其中点击“添加信息”进行信息添加项，同时，你也可以修改目标信息的路径及文件（说明修改完成后，别忘了点击“修改信息”信息按钮噢），你也可以给你的压缩包修改一个名字。最后点击“信息打包”按钮，进行打包；

2. 信息包展开：打包完成，你可以通过frmMain窗体中的展开程序进行压缩包展开，该展开形式对于存在的文件将覆盖，你可以修给代码，使之符合你自己的要求；

3. 你可以将你的压缩和该程序一同发给你的客户，这样，客户通过展开按钮便可以给你的程序进行信息更新了；

4. 你也可以将这些代码变通形式内嵌在你的程序中，通过文件关联，直接打开你的包文件，这样会更有趣；

5. 若你是Dephi或C++程序员，我相信你看了代码后，用你的方式做起来会更简单。

J 若仍不明白，或需求源代码，请来信告诉我，请来信告诉我，我会尽量满足你的要求！