程序|压缩用记事本打开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 :douhapysina.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
用VB6.0自制压缩与解压缩程序(二)
80酷酷网 80kuku.com
