答案:用记事本打开modMain.bas文件,copy以下内容到其中:
Attribute VB_Name = "modMain"
' ==============================================
' 信息打包与展开 (启动模块)
'
' 功能 :利用系统所存在的资源自作压缩与解压缩程序
'
' 作 者 :谢家峰
' 整理日期 :2004-08-08
' Email :douhapy@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 "系统已启动!", , App.EXEName: End
'获得系统安装目录
WindowsPath = GetWindowsDir
WindowsSysPath = GetWindowsSysDir
Load frmMain
frmMain.Show
End Sub
用记事本打开modAPI.bas文件,copy以下内容到其中:
Attribute VB_Name = "modAPI"
' ==============================================
' 信息打包与展开 (所调用的API及通用函数模块)
'
' 功能 :利用系统所存在的资源自作压缩与解压缩程序
'
' 作 者 :谢家峰
' 整理日期 :2004-08-08
' Email :douhapy@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 nSize 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 lpCommandLine 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, lpStartupInfo 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 lpszShortPath As String, ByVal cchBuffer As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpbuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpbuffer As String, ByVal nSize 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
' -----------------------------------------------------------
' 给目录添加分割线
'
' -----------------------------------------------------------
'
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
' -----------------------------------------------------------
' 调用API函数获得Windows的系统目录
'
' -----------------------------------------------------------
'
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
' -----------------------------------------------------------
' 调用API函数获取Windows目录
'
' -----------------------------------------------------------
'
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
' --------------------------------------
' 测试目录是否存在
'
' --------------------------------------
'
Public Function DirExists(Path As String) As Boolean
On Error Resume Next
'对于网络地址采用*.*形式
If InStr(Path, "\\") Then
DirExists = (Dir$(Path & "\*.*") <> "")
Else
DirExists = (Dir$(Path & "\nul") <> "")
End If
End Function
' --------------------------------------
' 建立文件夹(含多层结构)
'
' --------------------------------------
'
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
<
上一个:如何用VB.NET编写XML文档
下一个:用VB6.0自制压缩与解压缩程序(二)