一起学Excel专业开发17：Excel工时报表与分析系统开发（2）——创建特定应用加载宏

'声明全局常量
'应用程序名称
Public Const gsAPP_NAME As String = "PETRAS Time Sheet"
'应用程序版本
Public Const gsVERSION As String = "1.0"
'应用程序创建号
Public Const gsBUILD As String = ".003"
 
'命令栏名称常量
Public Const gsBAR_TOOLBAR As String = "PETRAS Toolbar"
 
'工作簿文件名常量
Public Const gsFILE_TIME_ENTRY As String = "PetrasTemplate.xlsx"
 
'工作表的代码名称常量
Public Const gsSHEET_TIME_ENTRY As String = "wksTimeEntry"
 
'加载宏中工作表wksUISettings单元格命名区域名称常量
Public Const gsRNG_NAME_LIST As String = "tblRangeNames"
 
'PetrasTemplate.xlsx中工作表wksTimeEntry名称常量
Public Const gsRNG_SET_HIDE_COLS As String = "setHideCols"
Public Const gsRNG_SET_SCROLL_AREA As String = "setScrollArea"
Public Const gsRNG_HAS_ERRORS As String = "errHasErrors"
Public Const gsRNG_INSERT_ROW As String = "ptrInsertRow"
Public Const gsRNG_EMPLOYEE_NAME As String = "inpEmployee"
Public Const gsRNG_WEEK_END_DATE As String = "inpWeekEnding"
 
'错误消息
Public Const gsERR_FILE_NOT_FOUND As String = "没有找到工作簿PetrasTemplate.xlsx."
Public Const gsERR_DATA_ENTRY As String = "在工时工作表中存在数据输入错误. 请在发送前修复."
 
'用户消息
Public Const gsMSG_BOOK_NOT_ACTIVE As String = "PetrasTemplate.xlsx工作簿必须是当前工作簿才能使用此命令."
Public Const gsMSG_POST_SUCCESS As String = "时间输入工作簿已成功发送."
Public Const gsMSG_POST_FAIL As String = "不能发送时间输入工作簿."
 
'状态栏消息
Public Const gsSTATUS_LOADING_APP As String = "装载应用程序, 请等待..."
 
'对话框标题常量
Public Const gsCAPTION_SELECT_FOLDER As String = "选择合并文件夹"
 
'注册设置常量
Public Const gsREG_APP As String = "Professional Excel Development\PetrasReporting"
Public Const gsREG_SECTION As String = "Settings"
Public Const gsREG_KEY As String = "ConsolidationPath"
 
'用于确保应用程序关闭代码只调用一次
Public gbShutdownInProgress As Boolean
'应用程序目录
Public gsAppDir As String
 
'初始化所有全局变量
Public Sub InitGlobals()
    '获取应用程序目录
    gsAppDir = ThisWorkbook.Path
    If Right$(gsAppDir, 1) <>"\" Then gsAppDir = gsAppDir & "\"
    '初始化全局变量
    gbShutdownInProgress = False
End Sub

'每次启动应用程序时初始化
Public Sub Auto_Open()
    Dim wkbBook As Workbook
 
    '启动应用程序时要首先要做的是
    '删除由于Excel崩溃或其他不正常退出而遗留的命令栏副本
    On Error Resume Next
   Application.CommandBars(gsBAR_TOOLBAR).Delete
    On Error GoTo 0
   
    '初始化全局变量
    InitGlobals
   
    '在做其他操作前确保找到了时间输入工作簿
    If Len(Dir$(gsAppDir &gsFILE_TIME_ENTRY)) > 0 Then
        Application.ScreenUpdating = False
        Application.StatusBar =gsSTATUS_LOADING_APP
       
        '创建命令栏
        BuildCommandBars
       
        '判断时间输入工作簿是否已打开
        '如果没有打开, 则打开.如果打开,则激活.
        On Error Resume Next
        Set wkbBook =Application.Workbooks(gsFILE_TIME_ENTRY)
        On Error GoTo 0
       
        If wkbBook Is Nothing Then
            Set wkbBook = Application.Workbooks.Open(_
                            gsAppDir &gsFILE_TIME_ENTRY)
        Else
            wkbBook.Activate
        End If
       
        '为工时输入工作簿应用工作表设置
        MakeWorksheetSettings wkbBook
       
        '重置关键的应用程序属性
        ResetAppProperties
    Else
        MsgBox gsERR_FILE_NOT_FOUND,vbCritical, gsAPP_NAME
        ShutdownApplication
    End If
End Sub

'为应用程序创建命令栏
Public Sub BuildCommandBars()
    Dim cbrBar As CommandBar
    Dim ctlButton As CommandBarButton
   
    '创建命令栏
    Set cbrBar =Application.CommandBars.Add(gsBAR_TOOLBAR, _
                           msoBarTop, False,True)
    cbrBar.Visible = True
   
    '添加控件
    Set ctlButton =cbrBar.Controls.Add(msoControlButton)
    ctlButton.Style = msoButtonIconAndCaption
    ctlButton.Caption = "传送到工作区"
    ctlButton.FaceId = 107
    ctlButton.OnAction ="PostTimeEntriesToNetwork"
   
    Set ctlButton =cbrBar.Controls.Add(msoControlButton)
    ctlButton.Style = msoButtonIconAndCaption
    ctlButton.Caption = "添加行"
    ctlButton.FaceId = 296
    ctlButton.OnAction ="AddMoreRows"
    ctlButton.BeginGroup = True
   
    Set ctlButton =cbrBar.Controls.Add(msoControlButton)
    ctlButton.Style = msoButtonIconAndCaption
    ctlButton.Caption = "清除数据输入"
    ctlButton.FaceId = 47
    ctlButton.OnAction ="ClearDataEntryAreas"
    ctlButton.BeginGroup = True
   
    Set ctlButton =cbrBar.Controls.Add(msoControlButton)
    ctlButton.Style = msoButtonCaption
    ctlButton.Caption = "退出PETRAS"
    ctlButton.OnAction ="ExitApplication"
    ctlButton.BeginGroup = True
End Sub

'将设置应用到时间输入工作簿的所有工作表
Public Sub MakeWorksheetSettings(ByRef wkbBook As Workbook)
    Dim rngCell As Range
    Dim rngSettingList As Range
    Dim rngHideCols As Range
    Dim sTabName As String
    Dim vSetting As Variant
    Dim wksSheet As Worksheet
   
    '用于接口设置的工作表中预定义名称名区域
    Set rngSettingList =wksUISettings.Range(gsRNG_NAME_LIST)
   
    '遍历接口工作簿中的工作表
    For Each wksSheet In wkbBook.Worksheets
        '要应用设置，工作表必须没有保护且可见
        '如果需要被保护和/或隐藏
        '则再次使用代码进行保护和隐藏
        wksSheet.Unprotect
        wksSheet.Visible = xlSheetVisible
       
        '隐藏需要隐藏的列
        Set rngHideCols = Nothing
        On Error Resume Next
        Set rngHideCols =wksSheet.Range(gsRNG_SET_HIDE_COLS)
        On Error GoTo 0
        If Not rngHideCols Is Nothing Then
            rngHideCols.EntireColumn.Hidden =True
        End If
       
        '遍历预定义名称名所在区域
        For Each rngCell In rngSettingList
            '判断当前工作表是否需要当前设置
            vSetting = Empty
            On Error Resume Next
            If rngCell.Value ="setScrollArea" Then
                '因为是Range对象所以滚动区域设置必须被单独处理
                Set vSetting =Application.Evaluate( _
                    "'" & wksSheet.Name &"'!" & rngCell.Value)
            Else
                vSetting =Application.Evaluate( _
                    "'" &wksSheet.Name & "'!" & rngCell.Value)
            End If
            On Error GoTo 0
       
            If Not IsEmpty(vSetting) Then
                If rngCell.Value ="setProgRows" Then
                    If vSetting > 0 Then
                       wksSheet.Range("A1").Resize(vSetting) _
                            .EntireRow.Hidden =True
                    End If
                ElseIf rngCell.Value ="setProgCols" Then
                    If vSetting > 0 Then
                       wksSheet.Range("A1").Resize(, _
                           vSetting).EntireColumn.Hidden = True
                    End If
                ElseIf rngCell.Value ="setScrollArea" Then
                    wksSheet.ScrollArea =vSetting.Address
                ElseIf rngCell.Value ="setEnableSelect" Then
                    wksSheet.EnableSelection =vSetting
                ElseIf rngCell.Value ="setRowColHeaders" Then
                    wksSheet.Activate
                    Application.ActiveWindow _
                        .DisplayHeadings =vSetting
                ElseIf rngCell.Value ="setVisible" Then
                    wksSheet.Visible = vSetting
                ElseIf rngCell.Value ="setProtect" Then
                    If vSetting Then
                        wksSheet.Protect ,True, True, True
                    End If
                End If
            End If
        Next rngCell
       
    Next wksSheet
   
    '让工时输入工作表处于活动状态
    sTabName = sSheetTabName(wkbBook,gsSHEET_TIME_ENTRY)
    wkbBook.Worksheets(sTabName).Activate
End Sub

'确保所有应用程序属性得到恢复
Public Sub ResetAppProperties()
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.EnableCancelKey = xlInterrupt
    Application.Cursor = xlDefault
End Sub