一起学Excel专业开发20：Excel工时报表与分析系统开发（3）——启动与关闭

Option Explicit
Option Private Module
 
'标题
Public Const gsAPP_TITLE As String ="PETRAS Reporting"
Public Const gsBACKDROP_TITLE As String ="PETRAS Backdrop"
Public Const gsMENU_BAR As String ="PETRAS Menu Bar"
Public Const gsRESULTS_TEMPLATE As String= "PetrasConsolidation.xltx"
 
'标识自定义文档属性名
Public Const gsPETRAS_TIMESHEET As String= "PetrasTimesheet"
Public Const gsPETRAS_RESULTS As String ="PetrasResults"
 
'注册表设置常量
Public Const gsREG_APP As String = "ProfessionalExcel Development\PETRAS Reporting"
Public Const gsREG_XL_ENV As String ="Excel Settings"
Public Const gsREG_SETTINGS As String ="Settings"
Public Const gsREG_CONSOLIDATION_PATH As String = "ConsolidationPath"
 
'全局伪常量, 例如在开始时设置且未更改的常量
Public gvaKeysToDisable As Variant
Public gbDebugMode As Boolean
 
'全局变量
Public gwbkBackDrop As Workbook  '背景工作簿
Public gwbkResults As Workbook   '当前合并结果工作簿
 
'初始化"常量"全局变量
'它们在应用程序运行时不会变化
Sub InitGlobals()
   gvaKeysToDisable = Array("^{F6}", "+^{F6}","^{TAB}", "+^{TAB}", "%{F11}", "%{F8}","^W", "^{F4}", _
                             "{F11}","%{F1}", "+{F11}", "+%{F1}", "^{F5}","^{F9}", "^{F10}")
 
    '使用已存在的调试文件来设置是否处于调试模式
   gbDebugMode = Dir(ThisWorkbook.Path & "\debug.ini")<> ""
End Sub

'检查应用程序是否可以在当前Excel版本中运行
Function CheckOKToStart() As Boolean
 
    'Excel 2000 = 版本 9
   If Val(Application.Version) < 9 Then
       MsgBox "PETRAS报表应用程序需要Excel2000或更高版本.",vbOKOnly, gsAPP_TITLE
       ThisWorkbook.Close False
       Exit Function
   End If
 
    '下面语句可运行,则OK!
   CheckOKToStart = True
End Function

'在注册表中存储Excel工作区设置
Sub StoreExcelSettings()
   Dim cbBar As CommandBar
   Dim sBarNames As String
   Dim objTemp As Object
   Dim wkbTemp As Workbook
 
    '一些属性需要打开工作簿,因此创建一个工作簿
   If ActiveWorkbook Is Nothing Then Set wkbTemp = Workbooks.Add
 
    '写入值来表明已存储了设置
   SaveSetting gsREG_APP, gsREG_XL_ENV, "Stored", "Yes"
 
    '在注册表中存储当前Excel设置,
    '用于安全的崩溃恢复
   With Application
       SaveSetting gsREG_APP, gsREG_XL_ENV, "DisplayStatusBar",CStr(.DisplayStatusBar)
       SaveSetting gsREG_APP, gsREG_XL_ENV, "DisplayFormulaBar",CStr(.DisplayFormulaBar)
       SaveSetting gsREG_APP, gsREG_XL_ENV, "Calculation",CStr(.Calculation)
       SaveSetting gsREG_APP, gsREG_XL_ENV, "IgnoreRemoteRequests",CStr(.IgnoreRemoteRequests)
       SaveSetting gsREG_APP, gsREG_XL_ENV, "Iteration",CStr(.Iteration)
       SaveSetting gsREG_APP, gsREG_XL_ENV, "MaxIterations",CStr(.MaxIterations)
 
        '获取可见的命令栏
       For Each cbBar In .CommandBars
            If cbBar.Visible Then sBarNames =sBarNames & "," & cbBar.Name
       Next
       
       SaveSetting gsREG_APP, gsREG_XL_ENV, "VisibleCommandBars",sBarNames
       SaveSetting gsREG_APP, gsREG_XL_ENV, "ShowWindowsInTaskbar",CStr(.ShowWindowsInTaskbar)
 
        '对于Excel 2002及以上版本的特殊项
       If Val(.Version) >= 10 Then
            Set objTemp = .CommandBars
            SaveSetting gsREG_APP,gsREG_XL_ENV, "DisableAskAQuestion",CStr(objTemp.DisableAskAQuestionDropdown)
            SaveSetting gsREG_APP,gsREG_XL_ENV, "AutoRecover", CStr(.AutoRecover.Enabled)
       End If
   End With
 
   If Not wkbTemp Is Nothing Then wkbTemp.Close False
End Sub

'从注册表中读取,恢复Excel工作区设置
Sub RestoreExcelSettings()
   Dim vKey As Variant
   Dim vBarName As Variant
   Dim objTemp As Object
 
    '从注册表中恢复最初的Excel设置
   With Application
        '恢复Excel菜单
       RestoreMenus
 
        '检查要还原的一些设置
       If GetSetting(gsREG_APP, gsREG_XL_ENV, "Stored","No") = "Yes" Then
            .DisplayStatusBar =CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "DisplayStatusBar", CStr(.DisplayStatusBar)))
            .DisplayFormulaBar =CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "DisplayFormulaBar",CStr(.DisplayFormulaBar)))
            .IgnoreRemoteRequests =CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "IgnoreRemoteRequests",CStr(.IgnoreRemoteRequests)))
            .Calculation =CLng(GetSetting(gsREG_APP, gsREG_XL_ENV, "Calculation",CStr(.Calculation)))
            .Iteration =CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "Iteration",CStr(.Iteration)))
            .MaxIterations = CLng(GetSetting(gsREG_APP,gsREG_XL_ENV, "MaxIterations", CStr(.MaxIterations)))
 
            '显示正确的工具栏
            On Error Resume Next
            For Each vBarName InSplit(GetSetting(gsREG_APP, gsREG_XL_ENV, "VisibleCommandBars"),",")
                Application.CommandBars(vBarName).Visible= True
            Next
            On Error GoTo 0
            .ShowWindowsInTaskbar =CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "ShowWindowsInTaskbar",CStr(.ShowWindowsInTaskbar)))
 
            '适用于Excel 2002及更高版本的特定内容
            If Val(.Version) >= 10 Then
                Set objTemp = .CommandBars
               objTemp.DisableAskAQuestionDropdown = CBool(GetSetting(gsREG_APP,gsREG_XL_ENV, "DisableAskAQuestion",CStr(objTemp.DisableAskAQuestionDropdown)))
                .AutoRecover.Enabled =CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "AutoRecover",CStr(.AutoRecover.Enabled)))
            End If
       End If
 
        '重新启用已禁用的快捷键
       If IsArray(gvaKeysToDisable) Then
            For Each vKey In gvaKeysToDisable
                .OnKey vKey
            Next
       End If
   End With
 
    '如果仍然存在,取消背景工作簿保护
   If WorkbookAlive(gwbkBackDrop) Then
       gwbkBackDrop.Unprotect
       gwbkBackDrop.Saved = True
   End If
End Sub

'恢复最初的菜单结构.在独立应用程序中,
'最简单的方法是重新打开xlb文件.
'不能在加载宏中执行这样的操作,
'因为这将破坏在此会话中所创建的任意自定义
Sub RestoreMenus()
    Dim cbCommandBar AsCommandBar
    Dim sPath As String
    Dim sToolbarFile AsString
 
    On Error Resume Next
 
    '重新打开xlsb工具栏自定义文件(如果存在),避免其变大
    sPath =Application.StartupPath
 
    '获取要打开的正确的工具栏文件的名称,
    '取决于Excel版本
    If Val(Application.Version)= 9 Then
        sToolbarFile =Left$(sPath, InStrRev(sPath, "\")) & "Excel.xlb"
    ElseIfVal(Application.Version) < 15 Then
        sToolbarFile =Left$(sPath, InStrRev(sPath, "\")) & "Excel" &Val(Application.Version) & ".xlb"
    Else
        sToolbarFile =Left$(sPath, InStrRev(sPath, "\")) & "Excel15.xlb"
    End If
 
    '如果有,重新打开工具栏文件
    If Dir(sToolbarFile)<> "" Then
        Workbooks.OpensToolbarFile, ReadOnly:=True
    Else
        '如果没有,必须自已整理
 
        '重新启用所有工具栏(包括Excel标准菜单)
        For Each cbCommandBarIn Application.CommandBars
           cbCommandBar.Enabled = True
        Next
 
        '删除自定义菜单栏
       Application.CommandBars(gsMENU_BAR).Delete
    End If
End Sub

'为应用程序配置Excel工作区
Sub ConfigureExcelEnvironment()
   Dim objTemp As Object
   Dim vKey As Variant
 
   With Application
        '设置所需的应用程序属性
       .Caption = gsAPP_TITLE
       .DisplayStatusBar = True
       .DisplayFormulaBar = False
       .Calculation = xlManual
 
       .DisplayAlerts = False
       .IgnoreRemoteRequests = True
       .DisplayAlerts = True
 
       .Iteration = True
       .MaxIterations = 100
 
        '对于Excel 2000及以上版本的特定项
       If Val(.Version) >= 9 Then
            .ShowWindowsInTaskbar = False
       End If
 
        '对于Excel 2002及以上版本的特定项
       If Val(.Version) >= 10 Then
            Set objTemp = .CommandBars
            objTemp.DisableAskAQuestionDropdown= True
            objTemp.DisableCustomize = True
            .AutoRecover.Enabled = False
       End If
 
        '根据是否要调试,具有稍微不同的环境状态
       If gbDebugMode Then
            '由于对环境的要求很高，因此应该设置一个热键组合来还原
            '键组合是Shift+Ctrl+R
            .OnKey "+^R","RestoreExcelSettings"
       Else
            '确保VBE不可见
            .VBE.MainWindow.Visible = False
 
            '禁用快捷键
            For Each vKey In gvaKeysToDisable
                .OnKey vKey, ""
            Next
       End If
   End With
End Sub