IDC资讯中心
用记事本打开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
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
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
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
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) = ""
next
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
next
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
next
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
next
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)
next
重新排序
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
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
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
next
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.description
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
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
next
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
next
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
next
writeprivateprofilestring "打包名称", "bagname", "" & txteditinfo(3), filename
end with
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
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
next
.listitems(i – 1).selected = true
editlstvinfo .selecteditem
end with
end with
case 3 关闭
unload me
end select
exit sub
errlab:
if err.number = 32755 then
exit sub
else
err.raise err.number, , err.description
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
