<div style="text-indent: 2em;"><p>这个模块(MWorkspace.bas)主要用来配置EXCEL VBA独立应用程序的环境,摘抄自《Excel专业开发》,分享下,也备自己不时之需。</p>

其中有一些常量或者函数是定义在其他模块文件中的,使用时需要自己定义。如 gsREG_XL_ENV 就是定义在MGlobals.bas中。

'
' Description:  This module holds code to save and restore the Excel workspace.
'
' Authors:      Stephen Bullen, www.oaltd.co.uk
'               Rob Bovey, www.appspro.com
'
' Chapter Change Overview
' Ch#   Comment
' --------------------------------------------------------------
' 06    Initial version
' 07    Kill the application event handler at shutdown
' 08    Adding the commandbar builder meant a change in a procedure name
'       Moved code to re-enable toolbars here from the old ResetMenus
' 09    Added call to SetIcon in new MAPIWrappers module
'
Option Explicit
Option Private Module
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Store the Excel workspace settings in the Registry
'
' Arguments:    None
'
' Date          Developer       Chap    Action
' --------------------------------------------------------------
' 02 Jun 04     Stephen Bullen  Ch06    Initial version
'
Sub StoreExcelSettings()
 
    Dim cbBar As CommandBar
    Dim sBarNames As String
    Dim objTemp As Object
    Dim wkbTemp As Workbook
 
    'Some properties require a workbook open, so create one
    If ActiveWorkbook Is Nothing Then Set wkbTemp = Workbooks.Add
 
    'Write a value to indicate that the settings have been stored.
    SaveSetting gsREG_APP, gsREG_XL_ENV, "Stored", "Yes"
 
    'Store the current Excel settings in the registry,
    'for safe crash-recovery
    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)
 
        'Which commandbars are visible
        For Each cbBar In .CommandBars
            If cbBar.Visible Then sBarNames = sBarNames & "," & cbBar.Name
        Next
        SaveSetting gsREG_APP, gsREG_XL_ENV, "VisibleCommandBars", sBarNames
 
        'Special items for Excel 2000 and up
        If Val(.Version) >= 9 Then
            SaveSetting gsREG_APP, gsREG_XL_ENV, "ShowWindowsInTaskbar", CStr(.ShowWindowsInTaskbar)
        End If
 
        'Special items for Excel 2002 and up
        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
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Restore the Excel workspace settings, reading them
'           from the Registry
'
' Arguments:    None
'
' Date          Developer       Chap    Action
' --------------------------------------------------------------
' 02 Jun 04     Stephen Bullen  Ch06    Initial version
' 02 Jun 04     Stephen Bullen  Ch07    Kill the event handler at shutdown
' 03 Jun 04     Stephen Bullen  Ch08    Renamed RestoreMenus to ResetCommandBars and moved re-enabling toolbars to here
'
Sub RestoreExcelSettings()
 
    Dim vKey As Variant
    Dim vBarName As Variant
    Dim objTemp As Object
    Dim cbCommandbar As CommandBar
 
    'Kill our event handler
    Set gclsEventHandler = Nothing
 
    'Restore the original Excel settings from the registry
    With Application
 
        'Ch08+
        'Ensure all menus are enabled
        EnableDisableMenus gsCONTEXT_ENABLE_ALL
 
        'Enable all the toolbars
        On Error Resume Next
        For Each cbCommandbar In .CommandBars
            cbCommandbar.Enabled = True
        Next
        On Error GoTo 0
 
        'Restore the Excel menus
        ResetCommandBars
        'Ch08-
 
        'Check that we have some settings to restore
        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)))
 
            'Show the correct toolbars
            On Error Resume Next
            For Each vBarName In Split(GetSetting(gsREG_APP, gsREG_XL_ENV, "VisibleCommandBars"), ",")
                Application.CommandBars(vBarName).Visible = True
            Next
            On Error GoTo 0
 
            'Specific stuff for Excel 2000 and up
            If Val(.Version) >= 9 Then
                .ShowWindowsInTaskbar = CBool(GetSetting(gsREG_APP, gsREG_XL_ENV, "ShowWindowsInTaskbar", CStr(.ShowWindowsInTaskbar)))
            End If
 
            'Specific stuff for Excel 2002 and up
            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
 
        'Reenable the shortcut keys we disabled
        If IsArray(gvaKeysToDisable) Then
            For Each vKey In gvaKeysToDisable
                .OnKey vKey
            Next
        End If
    End With
 
    'Unprotect the backdrop workbook, if it still exists
    If WorkbookAlive(gwbkBackDrop) Then
        gwbkBackDrop.Unprotect
        gwbkBackDrop.Saved = True
    End If
 
End Sub
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Configure the Excel workspace for our application
'
' Arguments:    None
'
' Date          Developer       Chap    Action
' --------------------------------------------------------------
' 02 Jun 04     Stephen Bullen  Ch06    Initial version
' 03 Jun 04     Stephen Bullen  Ch08    Moved menu OnKey assignments to here
'                                       Moved toolbar hiding to here
' 03 Jun 04     Stephen Bullen  Ch09    Added call to SetIcon in new MAPIWrappers module
 
Sub ConfigureExcelEnvironment()
 
    Dim objTemp As Object
    Dim vKey As Variant
    Dim cbCommandbar As CommandBar
 
    With Application
        'Set the Application properties we want
        .Caption = gsAPP_TITLE
        .DisplayStatusBar = True
        .DisplayFormulaBar = False
        .Calculation = xlManual
 
        .DisplayAlerts = False
        .IgnoreRemoteRequests = True
        .DisplayAlerts = True
 
        .Iteration = True
        .MaxIterations = 100
 
        'Specific items for Excel 2000 and up
        If Val(.Version) >= 9 Then
            .ShowWindowsInTaskbar = False
        End If
 
        'Specific items for Excel 2002 and up
        If Val(.Version) >= 10 Then
            Set objTemp = .CommandBars
            objTemp.DisableAskAQuestionDropdown = True
            objTemp.DisableCustomize = True
            .AutoRecover.Enabled = False
        End If
 
        'We'll have slighly different environment states, depending on whether we're debugging or not
        If gbDEBUGMODE Then
            ' Since we have blitzed the environment, we should set a hot key combination to restore it.
            ' That key combination is Shift+Ctrl+R
            .OnKey "+^R", "RestoreExcelSettings"
        Else
            'Make sure the VBE isn't visible
            On Error Resume Next
            .VBE.MainWindow.Visible = False
            On Error GoTo 0
 
            'Disable a whole host of shortcut keys
            For Each vKey In gvaKeysToDisable
                .OnKey vKey, ""
            Next
        End If
 
        'Ch08+
        'Hide all the toolbars
        On Error Resume Next
        For Each cbCommandbar In Application.CommandBars
            cbCommandbar.Visible = False
            cbCommandbar.Enabled = False
        Next
        On Error GoTo 0
 
        'Set up keyboard equivalents for some key menu items
'        .OnKey "^N", "MenuFileNew"
'        .OnKey "^n", "MenuFileNew"
'        .OnKey "^O", "MenuFileOpen"
'        .OnKey "^o", "MenuFileOpen"
    End With
 
    'Ch09
    SetIcon ApphWnd, ThisWorkbook.Path & "\" & gsICON_FILE
 
End Sub
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Comments: Copies the backdrop workbook from the addin to a
'           new workbook and configures it
'
' Arguments:    None
'
' Date          Developer       Chap    Action
' --------------------------------------------------------------
' 02 Jun 04     Stephen Bullen  Ch06    Initial version
'
Sub PrepareBackDrop()
 
    Dim wkbBook As Workbook
 
    'Do we already have a backdrop object?
    If Not WorkbookAlive(gwbkBackDrop) Then
 
        'See if there's already a backdrop workbook out there
        Set gwbkBackDrop = Nothing
        For Each wkbBook In Workbooks
            If wkbBook.BuiltinDocumentProperties("Title") = gsBACKDROP_TITLE Then
                Set gwbkBackDrop = wkbBook
                Exit For
            End If
        Next
 
        If gwbkBackDrop Is Nothing Then
            'Copy the backdrop sheet out of this workbook
            'into a new one for display
            wksBackdrop.Copy
            Set gwbkBackDrop = ActiveWorkbook
            gwbkBackDrop.BuiltinDocumentProperties("Title") = gsBACKDROP_TITLE
        End If
    End If
 
    With gwbkBackDrop
        .Activate
 
        'Select the full region that encompasses the backdrop
        'graphic, so we can use Zoom = True to size it to fit
        .Worksheets(1).Range("rgnBackDrop").Select
 
        'Set the Window View options to hide everything
        With .Windows(1)
            .WindowState = xlMaximized
            .Caption = ""
            .DisplayHorizontalScrollBar = False
            .DisplayVerticalScrollBar = False
            .DisplayHeadings = False
            .DisplayWorkbookTabs = False
 
            'Zoom the selected area to fit the screen
            .Zoom = True
        End With
 
        'Prevent selection or editing of any cells on the backdrop
        With .Worksheets(1)
            .Range("ptrCursor").Select
            .ScrollArea = .Range("ptrCursor").Address
            .EnableSelection = xlNoSelection
            .Protect DrawingObjects:=True, UserInterfaceOnly:=True
        End With
 
        'Protect the backdrop workbook, to remove the
        'control menu
        .Protect Windows:=True
        .Saved = True
    End With
 
End Sub