Self-made compression and decompression program with VB6.0 (i.)

Program | Compression when we write the program, will often encounter the program information content updates, for small file updates, can provide customers to the network download, but for large and many files, due to the network reasons, through the download is not practical, often update incomplete, affecting the operation of the program. When I was writing "Business Entertainment channel system", also encountered such a problem, for large video and picture files, I consider the use of compressed packets to provide to customers, but by using the compression program but I can not be extracted from my files as required to the corresponding directory, At that time I thought about why not make a compression and decompression program. Unzip the file to the location where the program is being extracted.

For this project, I carefully studied the VB installation program, the original VB is the system from the resources to carry out compression and decompression, such as MakeCab.exe, Vb6stkit.dll and so on.

Actually really do it is quite simple, is called a few API functions can be done. Recently, there is free time to look at their old procedures, so decided to organize the program out, and share with you.



Here is a specific program to write the module, first you need to create a project (the name is determined by yourself):

1. Add two modules, here I give them respectively named Modapi, Modmain;

2. Add three forms, where I named them respectively Frmmain, Frmlogin, Frmaddinfo;

3. The following is the source code content of each module, please save the project, and then go to the project folder, the following prompts for the source copy;



Use Notepad to open the Frmmain.frm file, copy the following:



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 = "Information file Update"

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 ' Screen Center

Begin Vb.commandbutton Cmdok

Caption = "Export Update list"

Height = 375

Index = 3

left = 5385

TabIndex = 6

top = 4980

Width = 1545

End

Begin Vb.commandbutton Cmdok

Caption = "Off"

Height = 375

Index = 2

left = 7620

TabIndex = 5

top = 4980

Width = 885

End

Begin Vb.commandbutton Cmdok

Caption = "Package"

Height = 375

Index = 1

left = 3810

TabIndex = 1

top = 4980

Width = 885

End

Begin Vb.commandbutton Cmdok

Caption = "Expand"

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 = "ordinal"

Object.width = 1235

EndProperty

Beginproperty ColumnHeader (2) {bdd1f052-858b-11d1-b16a-00c0f0283628}

Subitemindex = 1

Text = "Compressed package file"

Object.width = 6068

EndProperty

Beginproperty ColumnHeader (3) {bdd1f052-858b-11d1-b16a-00c0f0283628}

Subitemindex = 2

Text = "Target Information"

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 = "About this program ..."

Height = 255

left = 7260

TabIndex = 8

top = 60

Width = 1215

End

Begin VB. Label Lblinfo

AutoSize =-1 ' True

Caption = "Please wait, the package information file is being created ..."

Height = 180

Index = 1

left = 30

TabIndex = 7

top = 4740

Width = 4980

End

Begin VB. Label Lblinfo

AutoSize =-1 ' True

Caption = "Expand Packaging information Update list:"

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





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

' Information packaging and expansion (main form module, expanded form)

'

' function: Using the resources of the system to compress and decompress the program

'

' Author: Shei Jia

' Collation Date: 2004-08-08

' Email:d ouhapy@sina.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

Description

' Cab is a compressed package under the System installation directory

' File is the name of a filename in the compressed package (you need to add the ' @ ' character before the file name)

' Dest the full pathname after extracting a file in a compressed package

' Icab is the number of compressed packets

' Ssrc temporary folder, a valid folder path



Dim s_filenames () as String ' source filename (without path)

Dim d_filenames () as String ' destination file name (including path)

Dim Cab_filename as String ' package filename





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 & "\ Update. ini"

' Find package file information

S_filenames = GetFiles (App.Path & "\*.cab_")

If UBound (s_filenames) = 0 Then

MsgBox "The Business Channel System File Update" package file is not found in the current directory! ",, App.EXEName

Exit Sub

End If



If UBound (s_filenames) > 1 Then

With Comdinfo

. Filter = "Business Channel System File update package |*.cab_|"

. DialogTitle = "Please specify the location of the business channel System Files Update package"

. 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



' Copy the current package to the System installation folder

If fileexists (Windowspath & cab_filename) Then Kill Windowspath & Cab_filename

FileCopy App.Path & "\" & Cab_filename, Windowspath & Cab_filename

' Convert package path information (for files under the system installation directory)

Cab_filename = Windowspath & Cab_filename

SetAttr Cab_filename, Vbnormal



' Get update. ini ' file

j = Extractfilefromcab (Cab_filename, "@ update. ini", FileName, 1, App.Path & "\")

SetAttr FileName, Vbnormal



Lblinfo (1). Visible = False

Pgbar.visible = True

Screen.MousePointer = 1

DoEvents



If j = 0 Then

MsgBox "This package information is incomplete, or not" Business Channel System File Update "Package! "& VbCrLf & vbCrLf &" Decompression is not completed, please request the latest update package! ",, App.EXEName

' Delete the replication package under the System installation directory

Kill Cab_filename

Exit Sub

Else

SetAttr FileName, Vbnormal

End If



Screen.MousePointer = 11

' Extract information

FileNum = CLng (CLng (readinifile (filename, number of files, FileNum))

ReDim S_filenames (FileNum)

ReDim D_filenames (FileNum)

' Where S_filenames's last data is the playback information file

For i = 1 to FileNum

S_filenames (i-1) = Readinifile (FileName, "source file information", "File" & i)

S_filenames (i-1) = GetFileName (S_filenames (i-1))

D_filenames (i-1) = Readinifile (FileName, "Destination file information", "File" & i)

DoEvents

Next



LstInfo.ListItems.Clear

Pgbar.min = 1

Pgbar.max = FileNum + 1



For i = 1 to FileNum

DoEvents

' Create a folder

Createfloder D_filenames (i-1)

' Extract Files

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 "This package information is incomplete, or not" Business Channel System File Update "Package! "& VbCrLf & vbCrLf &" Decompression is not completed, please request the latest update package! ",, 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



' Delete the replication package under the System installation directory

Kill Cab_filename

Kill FileName

Pgbar.value = FileNum + 1



MsgBox "Decompression complete, System update complete, thank you for using!" ",, App.EXEName

Pgbar.min = 0

Pgbar.value = 0



Case 1 ' Execution information packaging

LstInfo.ListItems.Clear

Frmlogin.show 1, Me

Case 2

Unload Me

Case 3

If lstInfo.ListItems.count = 0 Then MsgBox "No information available for export!" ",, App.EXEName:Exit Sub

With Frmmain.comdinfo

. Filter = "Update list information |*.txt"

. DialogTitle = "Export Package list information file"

. Initdir = CurDir ()

. Flags = cdlofnhidereadonly

. FileName = "Update list. txt"

On Error GoTo Errlab

. Showsave



FileName =. FileName

If fileexists (FileName) Then

SetAttr FileName, Vbnormal

Kill FileName

End If

' Export information

With Lstinfo

WritePrivateProfileString "Number of files", "FileNum", CStr (. Listitems.count), FileName

For i = 1 to. Listitems.count

WritePrivateProfileString "Compress package file Information", "File" & I,. ListItems (i). SubItems (1), FileName

WritePrivateProfileString "target file Information", "File" & I,. ListItems (i). SubItems (2), FileName

Next

End With

End With

The MsgBox "Information list is exported in the & filename &" File! ",, App.EXEName



Case Else

End Select



Screen.MousePointer = 1

Exit Sub



Errlab:

If Err.Number = 32755 Then

' Extract Files

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 (Fi Lenum)

' Delete the replication package under the System installation directory

If fileexists (cab_filename) Then Kill cab_filename

Kill FileName



MsgBox "You canceled the location of the specified user information, the user information is placed by default in" & D_filenames (FileNum) & ""! " _

& VbCrLf & vbCrLf & "Decompression complete, System update complete, thank you for using!" ",, 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 are nothing) Then

Lstinfo.tooltiptext = "[Target info]" & Item.listsubitems (2)

End If

End Sub