.NET开发：用VB6.0自制压缩与解压缩程序(二)

热点排行

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

类别：.NET开发点击：0 评论：0 推荐：

用记事本打开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 :[email protected]

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

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.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

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.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

本文地址：http://com.8s8s.com/it/it43643.htm