用VB6.0自制压缩与解压缩程序(一)

80酷酷网    80kuku.com

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

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

分享到
  • 微信分享
  • 新浪微博
  • QQ好友
  • QQ空间

上一篇VB.NET启动外部程序

下一篇VB.net进阶:如何实现序列化

相关文章

点击：