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

Program | Compress to open modmain.bas file with Notepad, copy the following content to it:



Attribute vb_name = "Modmain"



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

' Information packaging and expansion (startup module)

'

' 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



Public Windowspath as String

Public Windowssyspath as String



Sub Main ()

Dim Boottrappath as String

Dim Setupfilepath as String

Dim Regexefilepath as String



Dim Reginfo () as String

Dim regstr () as String

Dim Regfilename as String

Dim Str as String



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 Integer



If app.previnstance Then MsgBox "system started!", App.EXEName:End

' Get System installation directory

Windowspath = Getwindowsdir

Windowssyspath = Getwindowssysdir



Load Frmmain

Frmmain.show

End Sub



Use Notepad to open the Modapi.bas file, copy the following:



Attribute vb_name = "Modapi"



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

' Information packaging and expansion (API and common function modules invoked)

'

' 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



Public Declare Function getprivateprofilestring Lib "kernel32" Alias "Getprivateprofilestringa" (ByVal Lpapplicationname As String, ByVal lpkeyname as any, ByVal Lpdefault as String, ByVal lpreturnedstring as String, ByVal NS Ize as Long, ByVal lpFileName as String) as Long

Public Declare Function writeprivateprofilestring Lib "kernel32" Alias "Writeprivateprofilestringa" (ByVal Lpapplicationname As String, ByVal lpkeyname as any, ByVal lpstring as any, ByVal lpFileName as String) as Long



Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpapplicationname as String, ByVal Lpco Mmandline as String, lpprocessattributes as Security_attributes, lpthreadattributes as Security_attributes, ByVal bInheritHandles as Long, ByVal dwcreationflags as Long, lpenvironment as any, ByVal lpcurrentdriectory as String, Lpstartu pinfo as Startupinfo, lpprocessinformation as process_information) as Long

Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hhandle as Long, ByVal dwmilliseconds as long) as long

Public Declare Function CloseHandle Lib "kernel32" (ByVal Hobject as long) as long



Public Declare Function getshortpathname Lib "kernel32" Alias "Getshortpathnamea" (ByVal Lpszlongpath as String, ByVal LPs Zshortpath as String, ByVal Cchbuffer as Long

Public Declare Function getwindowsdirectory Lib "kernel32" Alias "Getwindowsdirectorya" (ByVal lpbuffer as String, ByVal n Size as long) as long

Public Declare Function getsystemdirectory Lib "kernel32" Alias "Getsystemdirectorya" (ByVal lpbuffer as String, ByVal nSi Ze as long) as long



Public Const gstrsep_dir$ = "\"

Public Const gstrsep_urldir$ = "/"

Public Const gintmax_size% = 255



Public Const INFINITE = &hffff



Public Type Startupinfo

CB as Long

Lpreserved as String

Lpdesktop as String

Lptitle as String

DwX as Long

Dwy as Long

Dwxsize as Long

Dwysize as Long

Dwxcountchars as Long

Dwycountchars as Long

Dwfillattribute as Long

dwflags as Long

Wshowwindow as Integer

CbReserved2 as Integer

LpReserved2 as Long

hStdInput as Long

Hstdoutput as Long

Hstderror as Long

End Type



Public Type Process_information

Hprocess as Long

Hthread as Long

Dwprocessid as Long

dwThreadID as Long

End Type



Public Type Security_attributes

Nlength as Long

Lpsecuritydescriptor as Long

bInheritHandle as Long

End Type





Function Stripterminator (ByVal strstring As String) as String

Dim Intzeropos as Integer



Intzeropos = InStr (strstring, chr$ (0))

If intzeropos > 0 Then

Stripterminator = left$ (strstring, intZeroPos-1)

Else

Stripterminator = strstring

End If

End Function



' -----------------------------------------------------------

' Add a split line to the directory

'

' -----------------------------------------------------------

'

Sub adddirsep (strpathname as String)

If Right (Trim (Strpathname), Len (Gstrsep_urldir)) <> Gstrsep_urldir and _

Right (Trim (Strpathname), Len (Gstrsep_dir)) <> Gstrsep_dir Then

Strpathname = rtrim$ (strpathname) & Gstrsep_dir

End If

End Sub



' -----------------------------------------------------------

' Call API function to get Windows system directory

'

' -----------------------------------------------------------

'

Function Getwindowssysdir () as String

Dim Strbuf as String



Strbuf = space$ (gintmax_size)

If getsystemdirectory (Strbuf, gintmax_size) > 0 Then

Strbuf = Stripterminator (strbuf)

Adddirsep Strbuf



Getwindowssysdir = Strbuf

Else

Getwindowssysdir = vbNullString

End If

End Function



' -----------------------------------------------------------

' Invoke API function to get Windows directory

'

' -----------------------------------------------------------

'

Function Getwindowsdir () as String

Dim Strbuf as String



Strbuf = space$ (gintmax_size)



If getwindowsdirectory (Strbuf, gintmax_size) > 0 Then

Strbuf = stripterminator$ (strbuf)

Adddirsep Strbuf



Getwindowsdir = Strbuf

Else

Getwindowsdir = vbNullString

End If

End Function



' --------------------------------------

' Test whether the directory exists

'

' --------------------------------------

'

Public Function direxists (Path as String) as Boolean

On Error Resume Next



' Use *.* form for network address

If InStr (Path, "\") Then

Direxists = (dir$ (Path & "\*.*") <> "")

Else

Direxists = (dir$ (Path & "\nul") <> "")

End If

End Function



' --------------------------------------

' Create a folder (including multiple layers of structure)

'

' --------------------------------------

'

Public Sub Createfloder (Floder as String)

Dim I as Integer

Dim Path as String

Dim floderstr () as String



On Error Resume Next

Floderstr = Split (Floder, "\")

Path = floderstr (0)

For i = 1 to UBound (FLODERSTR)-1

Path = path & "\" & Floderstr (i)

If not direxists (Path) Then

MkDir Path

End If

Next

End Sub



' --------------------------------------

' Get short filenames with long filenames

'

' --------------------------------------

'

Function Getshortfilename (FileName As String) as String

Dim Str as String

str = String (LenB (FileName), CHR (0))



If getshortpathname (filename, str, LenB (filename)) <> 0 Then

str = left (str, INSTR (str, vbNullChar)-1)

If str = "" Then

Getshortfilename = FileName

Else

Getshortfilename = str

End If

Else

Getshortfilename = FileName

End If

End Function



' --------------------------------------

' Get filename

'

' --------------------------------------

'

Public Function GetFileName (Filenamepath As String) as String

Dim Auxvar () as String



Auxvar () = Split (Filenamepath, "\",, vbTextCompare)

GetFileName = Auxvar (UBound (Auxvar))

End Function



' --------------------------------------

' Get the file name extension

'

' --------------------------------------

'

Public Function Getext (FileName As String) as String

Dim Auxvar () as String



On Error Resume Next

Auxvar () = Split (FileName, "\",, vbTextCompare)

Auxvar () = Split (Auxvar (UBound (Auxvar)), ".", vbTextCompare)

Getext = Auxvar (UBound (Auxvar))

End Function



' --------------------------------------

' Test if file exists (cannot test hidden and system files)

'

' --------------------------------------

'

Public Function fileexists (FileName as String) as Boolean

On Error Resume Next

FileExists = (dir$ (FileName) <> "")

End Function



' --------------------------------------

' Find files

'

' --------------------------------------

'

Function GetFiles (filespec As String, Optional Attributes as Vbfileattribute) as String ()

Dim result () as String

Dim FileName As String, count as Long, path2 as String

Const Alloc_chunk = 50



ReDim result (0 to Alloc_chunk) as String

FileName = dir$ (filespec, Attributes)

Do While Len (FileName)

Count = Count + 1

If count > UBound (Result) Then

ReDim Preserve Result (0 to Count + alloc_chunk) as String

End If

Result (count) = FileName

FileName = dir$

Loop



ReDim Preserve Result (0 to count) as String

GetFiles = result



End Function



' --------------------------------------

' Convert string

'

' --------------------------------------

'

Public Function stringfrombuffer (buffer as String) as String

Dim NPOs as Long



NPOs = InStr (buffer, vbNullChar)

If NPOs > 0 Then

Stringfrombuffer = left$ (buffer, nPos-1)

Else

Stringfrombuffer = Buffer

End If

End Function



' --------------------------------------

' Write content to a text file

'

' --------------------------------------

'

Sub writetextfilecontents (text as String, FileName as String, Optional Appendmode as Boolean)

Dim Fnum as Integer, IsOpen as Boolean



On Error GoTo Error_Handler

Fnum = FreeFile ()

If Appendmode Then

Open FileName for Append as #fnum

Else

Open FileName for Output as #fnum

End If

IsOpen = True

Print #fnum, text

Error_Handler:

If IsOpen Then Close #fnum

If Err Then err.raise Err.Number, Err.Description

End Sub



' --------------------------------------

' Read the information to the INI file

'

' --------------------------------------

'

Public Function Readinifile (ByVal strinifile As String, ByVal strsection as String, ByVal strkey As String) as String

Dim Strbuffer as String * 255



If getprivateprofilestring (strsection, strkey, vbNullString, Strbuffer, 255, Strinifile) Then

Readinifile = Stringfrombuffer (Strbuffer)

End If

End Function



' --------------------------------------

' Add information to the ListView control

'

' --------------------------------------

'

Sub Lstvinfo_add (Lstvcontrol as ListView, infonum as Integer, Selectedflag as Boolean, ParamArray infostr ())

Dim I as Integer



With Lstvcontrol

. Listitems.add, Trim (infostr (0))

If Selectedflag Then

. ListItems (. Listitems.count). Selected = True

Else

. ListItems (. Listitems.count). Selected = False

End If



For i = 2 to Infonum

. ListItems (. Listitems.count). Listsubitems.add, Trim (Infostr (i-1))

Next

. ListItems (. Listitems.count). EnsureVisible

End With

End Sub

Since then, the code copy is complete, then you open the project, compile and run.

1. Information Packaging: Click "Pack and Go" in the Frmmain form until you open the Frmaddinfo form, click "Add Info" to add the item, and you can also modify the path and file of the target information (note that after the modification is complete, don't forget to click the "Modify Info" message button OH), You can also modify a name for your compressed package. Finally click on the "Information packaging" button, packaging;

2. Information Packet expansion: Packaging completed, you can through the Frmmain form of the expansion program to expand the package, the expansion of the form for existing files will be covered, you can repair to the code to meet your own requirements;

3. You can send your compression and the program to your customers, so that customers through the expansion button will be able to update your program information;

4. You can also embed these code forms in your program, through the file association, directly open your package file, this will be more interesting;

5. If you are a dephi or C + + programmer, I believe that you read the code, it will be easier to do it your way.



J If still do not understand, or demand source code, please write to tell me, please write to me, I will try to meet your requirements!