frmsetup1.frm

一个很好的教务管理小程序

VERSION 5.00
Begin VB.Form frmsetup1 
   Caption         =   "Form2"
   ClientHeight    =   4212
   ClientLeft      =   48
   ClientTop       =   300
   ClientWidth     =   5316
   LinkTopic       =   "Form2"
   ScaleHeight     =   4212
   ScaleWidth      =   5316
   StartUpPosition =   3  '窗口缺省
End
Attribute VB_Name = "frmsetup1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Load()
Const strINI_FILES$ = "Files"    '安装的缺省节
Const strEXT_GRP$ = "GRP"     '程序组的扩展名
Const SW_HIDE = 0
Dim strGroupName As String     '程序组名
Dim sFile As FILEINFO         '第一个文件行信息
Dim Mypath As String          '  ￠存放当前路径

gfRegDAO = False
On Error GoTo MainError

'￠设置窗体的字体
SetFormFont Me
Me.Font.Size = 24
Me.Font.Bold = True '粗体

'为消息框调用等，初始化空行变量
LF$ = Chr$(10)  '￠换行符
LS$ = LF$ & LF$
CRLF = Chr$(13) & Chr$(10)  '￠回车加换行

'初始化由全局变量和窗体/控件使用的字符串资源
GetStrings   ' 加载字符串资源到全局变量及窗体/控件中
'获取 Windows 和 Windows\System 目录
gstrWinDir = GetWindowsDir()
gstrWinSysDir = GetWindowsSysDir()

If InStr(gstrWinSysDir, gstrWinDir) = 0 Then
If WriteAccess(gstrWinSysDir) = False Then
gstrWinSysDir = gstrWinDir
End If
End If

' 安装的所需信息，如安装标志和文件信息均从发现 SETUP.LST 的目录的拷贝中读出。
'￠将"Setup.lst"文件复制到Window目录下
Mypath = CurDir
AddDirSep Mypath
Mypath = Mypath & gstrFILE_SETUP
gstrSetupInfoFile = gstrWinDir & gstrFILE_SETUP
FileCopy Mypath, gstrSetupInfoFile

'￠从"Setup.lst"文件中读出应用程序的名字
gstrAppName = ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_APPNAME)

If gstrAppName = gstrNULL Then
'￠显示一个消息对话框，表示出现错误然后退出
MsgError ResolveResString(resNOSETUPLST), MB_OK Or MB_ICONSTOP, gstrSETMSG
gstrTitle = ResolveResString(resSETUP, "|1", gstrAppName)
ExitSetup Me, gintRET_FATAL
End If

'￠从资源文件中读出一条信息: gstrTitle = "AppName(程序名)安装程序"
gstrTitle = ResolveResString(resSETUP, "|1", gstrAppName)
If gfSilent Then LogSilentMsg gstrTitle & CRLF

' 这是在安装图标的组的缺省名。
gstrDefGroup = ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_DEFGROUP)
If gstrDefGroup = gstrNULL Then
gstrDefGroup = gstrAppName
End If

Public Function ResolveResString(ByVal resID As Integer, _
ParamArray varReplacements() As Variant) As String
'￠ resID - 资源标识符；[varReplacements] - 成对的宏/替换值
Dim intMacro As Integer    '￠循环变量
Dim strResString As String   '￠保存从资源文件读出的字符串
strResString = LoadResString(resID)  '￠从资源文件中读出resID索引号对应的字符串

' For each 循环读入成对的宏/值...
For intMacro = LBound(varReplacements) To UBound(varReplacements) Step 2
Dim strMacro As String ' ￠被替换的宏
Dim strValue As String      '￠替换的宏

strMacro = varReplacements(intMacro)
On Error GoTo MismatchedPairs
strValue = varReplacements(intMacro + 1)
On Error GoTo 0
' 所有出现的 strMacro 替换为 strValue
Dim intPos As Integer
Do
intPos = InStr(strResString, strMacro)
        If intPos > 0 Then
            strResString = Left$(strResString, intPos - 1) & strValue & _
Right$(strResString, Len(strResString) - Len(strMacro) - intPos + 1)
End If
Loop Until intPos = 0
Next intMacro

ResolveResString = strResString
Exit Function
MismatchedPairs:
Resume Next
End Function

Function ReadIniFile(ByVal strIniFile As String, ByVal strSection As String, _
ByVal strKey As String) As String
'￠ [strIniFile] - 要读的 .LST 文件名；[strSection] - 找到关键字的节；
'￠ [strKey] - 要获取值的关键字名称
Dim strBuffer As String
Dim intPos As Integer

'如果读 .INI 文件成功，去掉任何由 Windows API GetPrivateProfileString 返回的尾随的零。
'￠产生255个字符来初始化strBuffer
strBuffer = Space$(gintMAX_SIZE)   '￠ gintMAX_SIZE = 255

'￠调用API函数来读.LST文件
If GetPrivateProfileString(strSection, strKey, gstrNULL, strBuffer, gintMAX_SIZE, strIniFile) > 0 Then
ReadIniFile = RTrim$(StripTerminator(strBuffer))
Else
ReadIniFile = gstrNULL
End If
End Function

Function StripTerminator(ByVal strString As String) As String
Dim intZeroPos As Integer  '￠标志位置
intZeroPos = InStr(strString, Chr$(0))
￠去掉字符串尾部的字符 "0"
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
     StripTerminator = strString
End If
End Function
ShowMainForm   ' 一得到标题，就显示安装屏幕的蓝色背景
ShowWelcomeForm    ' 显示"欢迎"对话框

' 获得应用程序可执行的文件名。
gstrAppExe = ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_APPEXE)
' 获得卸装的应用程序名。
gstrAppToUninstall = ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_APPTOUNINSTALL)
'￠ 常数gstrINI_APPTOUNINSTALL = "AppToUninstall"

' 如果设置了标志，则决无异议地使用缺省目标目录，而且用户没有机会去改变它。
If ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_FORCEUSEDEFDEST) = "1" Then
'￠常数gstrINI_FORCEUSEDEFDEST = "ForceUseDefDir"
gfForceUseDefDest = True
End If

' 读缺省目标目录。如果目录名与某个文件名冲突，则提示输入一个新的缺省目录
gstrDestDir = ResolveDestDir(ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_APPDIR))
'￠常数gstrINI_APPDIR = "DefaultDir"
 '这一条语句的作用是返回安装缺省路径
 While FileExists(gstrDestDir) = True Or gstrDestDir = gstrNULL
If MsgError(ResolveResString(resBADDEFDIR), MB_OKCANCEL Or _
MB_ICONQUESTION, gstrSETMSG) = IDCANCEL Then
'显示警告信息"安装程序不能决定有效的缺省目标目录。您需要指定目标目录。"
ExitSetup Me, gintRET_FATAL
End If
If gfNoUserInput = True Then
ExitSetup Me, gintRET_FATAL
Else
ShowPathDialog gstrDIR_DEST
End If
Wend

AddDirSep gstrDestDir  ' 保证在目标目录中有尾随反斜杠
Do
' 显示安装按钮和缺省目录。用户可以从此处改变目标目录。
ShowBeginForm
' 初始化使用的驱动器"表"和磁盘空间数组
InitDiskInfo
SetMousePtr gintMOUSE_HOURGLASS
ShowStaticMessageDialog ResolveResString(resDISKSPACE)

'￠ 显示信息"安装程序正在检查必要的磁盘空间..."
' 对 SETUP.LST 中将被安装的每一节，用该节的名称调用 CalcDiskSpace
CalcDiskSpace strINI_FILES  '￠常数strINI_FILES＝"Files"
CalcDiskSpace "MySection"
'CalcDiskSpace "MyOtherSection"
HideStaticMessageDialog
￠隐藏信息 "安装程序正在检查必要的磁盘空间..."

SetMousePtr gintMOUSE_DEFAULT
' 在所有 CalcDiskSpace 调用完成之后，调用 CheckDiskSpace
' 检查结果并显示警告窗体 (如果必要)。
' 如果用户希望尝试另一目标目录 (或清除并重试)，
' 那么 CheckDiskSpace 将返回 False。
Loop While CheckDiskSpace() = False
MakePath gstrDestDir, False '创建安装路径
' 如果需要，则创建主程序组
Const fDefCreateGroupUnderWin95 = False
' 判断是否建立程序组，缺省的是在 Windows 95 下，不应创建组，
Dim cIcons As Integer            '图标的记数。
Dim fAdditionalIcons As Boolean

' 通读 SETUP.LST 文件并决定需要多少图标。
cIcons = CountIcons(strINI_FILES)
' 如果您已经添加了自己的图标，在 SETUP.LST 文件的其他节中做同样工作。
cIcons = cIcons + CountIcons("MySection")
'cIcons = cIcons + CountIcons("MyOtherSection")
fAdditionalIcons = False  '将此变量设为True就可以在"开始菜单"上加一个菜单组
fAdditionalIcons = fAdditionalIcons Or (cIcons > 1)
fAdditionalIcons = fAdditionalIcons Or (Not TreatAsWin95())
' 下列变量决定是否为图标创建一个程序组。
' 它由 fNoGroupUnderWin95、fAdditionalIcons 和 FTreatAsWin95()　控制。
Dim fCreateGroup As Boolean

'￠判断是否建立程序组
If TreatAsWin95() Then
fCreateGroup = fDefCreateGroupUnderWin95 Or fAdditionalIcons
Else
' 如果是Win32 NT，总是创建一个程序组。
fCreateGroup = True
End If

strGroupName = ""
If fCreateGroup Then
strGroupName = frmGroup.GroupName(frmsetup1, gstrDefGroup)
fMainGroupWasCreated = True
End If


' 显示复制窗体并设置复制进程表百分比为 0
SetMousePtr gintMOUSE_HOURGLASS
ShowCopyDialog '￠显示frmCopy窗体
UpdateStatus frmCopy.picStatus, 0, True  '￠刷新进度条控件

' 总是从 Disk #1 开始。
gintCurrentDisk = 1
' 对于需要被安装在其中的每一节，用节名调用 CopySection
CopySection strINI_FILES     '复制文件
CopySection "MySection"       '可以在这里添加自定义的复制内容
CopySection "MyOtherSection"
UpdateStatus frmCopy.picStatus, 1, True
HideCopyDialog

' 现在，做所有要求的'不可见'的更新事物
SetMousePtr gintMOUSE_DEFAULT
ShowStaticMessageDialog ResolveResString(resUPDATING)   '显示"安装程序正在更新您的系统..."
' 注册所有已经保存到注册表数组中的文件。
RegisterFiles
' 注册所有出现在 Setup.lst 中 [Licenses] 一节中的许可证。
RegisterLicenses

' 如果安装了任何 DAO 文件，我们需要添加一些特殊的关键字
If gfRegDAO = True Then
RegisterDAO
End If

' 创建程序图标 (或链接，即快捷键)。
If (fMainGroupWasCreated = True) Or ((cIcons > 0) And TreatAsWin95()) Then
ShowStaticMessageDialog ResolveResString(resPROGMAN)
CreateIcons strINI_FILES, strGroupName
' 如果您已经添加了您自己的图标，在 SETUP.LST 中为其他节也做同样的工作。
CreateIcons "MySection", strGroupName '添加自定义的图标在"开始菜单"
'CreateIcons "MyOtherSection", strGroupName
End If

' 如果您仍需创建更多的图标，在此处插入代码，并确认您已经在上面将
'￠变量 fAdditionalIcons 设置为 True。
If Not fAdditionalIcons Then
  MsgError "内部安装程序用户化错误：fAdditionalIcons = False", _
vbOKOnly Or vbExclamation, gstrTitle
  ExitSetup Me, gintRET_FATAL
End If
CreateOSLink frmsetup1, strGroupName, gsDest.strAppDir & "My Exe 1.exe", _
"My Exe 1 command-line arguments", "My Exe 1"
CreateOSLink frmsetup1, strGroupName, gsDest.strAppDir & "My Exe 2.exe", _
"My Exe 2 command-line arguments", "My Exe 2"

'显示信息"安装程序正在创建程序光标..."
ShowStaticMessageDialog ResolveResString(resPROGMAN)
If gsDest.strAUTMGR32 <> "" Or gsDest.strRACMGR32 <> "" Then
'至少安装了这些程序组中的一个。继续并创建该程序组。
Dim strRemAutGroupName As String
strRemAutGroupName = ResolveResString(resREMAUTGROUPNAME)
' 为远程自动化图标创建组。
fCreateOSProgramGroup frmsetup1, strRemAutGroupName, False, False
'现在，为 AUTMGR32.EXE 和 RACMGR32.EXE 创建图标
If gsDest.strRACMGR32 <> "" Then
CreateOSLink frmsetup1, strRemAutGroupName, gsDest.strRACMGR32, _
"", ResolveResString(resRACMGR32ICON), False
End If
If gsDest.strAUTMGR32 <> "" Then
CreateOSLink frmsetup1, strRemAutGroupName, gsDest.strAUTMGR32, _
"", ResolveResString(resAUTMGR32ICON), False
End If
End If

'注册每个应用程序路径
If gstrAppExe <> "" Then
Dim strPerAppPath As String
strPerAppPath = ReadIniFile(gstrSetupInfoFile, gstrINI_SETUP, gstrINI_APPPATH)
AddPerAppPath gstrAppExe, gsDest.strAppDir, strPerAppPath
End If
ExitSetup:
HideStaticMessageDialog
RestoreProgMan

If fWithinAction() Then
'到现在，所有的登录动作应被中止或提交。
MsgError ResolveResString(resSTILLWITHINACTION), vbExclamation Or vbOKOnly, gstrTitle
ExitSetup Me, gintRET_FATAL
End If

ExitSetup Me, gintRET_FINISHEDSUCCESS
MainError:
Dim iRet As Integer
iRet = MsgError(Error$ & LS$ & ResolveResString(resUNEXPECTED), MB_RETRYCANCEL _
Or MB_ICONEXCLAMATION, gstrTitle)
If gfNoUserInput Then iRet = IDCANCEL

Select Case iRet
Case IDRETRY
Resume
Case IDCANCEL
ExitSetup Me, gintRET_ABORT
Resume
'结束 Case
End Select
End Sub