當我們編寫程序時，會常常遇到程序信息內容更新的問題，對于小的文件更新，可以提供給客戶自己到網絡上下載，但對于大且多的文件，由于網絡的原因，通過下載卻又不實際，動輒是更新不完整，影響了程序的運行。當時我編寫“商務娛樂頻道系統”時，也遇到了這樣的問題，對于大型的視頻及圖片文件，我考慮到了使用壓縮包提供給客戶，但是通過使用壓縮程序卻不能將我的文件按要求進行解壓到其他相應的目錄，那時我想到了何不自己制作壓縮與解壓縮程序呢。解壓時將文件解壓到程序所要的位置。
為了這個項目，我仔細的研究了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 :[email protected]
'
' ==============================================
'
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
