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

注：所谓特定应用加载宏，是指只能在专门为它所设计的工作簿上工作的一类加载宏。

Excel工时报表与分析系统（PETRAS）加载宏的功能：

1.启动和初始化应用程序

2.为应用程序的各项功能创建工具栏

3.打开和初始化“工时输入”工作簿

4.允许用户将数据输入工作簿中的内容复制到预先设定好的合并区

5.允许用户向“工时输入”工作表中添加更多的数据输入行

6.允许用户清除数据输入区域中的数据，以便重新使用工时输入表

7.允许用户关闭PETRAS程序

8.添加自定义属性，合并程序可据此查找“工时输入”工作簿的所有实例进程

在《一起学Excel专业开发16：使用表驱动的方法管理工作表用户接口》中，我们已经创建了表驱动的用于接口工作簿的工作表。

声明全局常量和变量

在模块MGlobals中，声明全局常量和变量：

代码语言：javascript复制

'声明全局常量
'应用程序名称
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 DevelopmentPetrasReporting"
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

启动和初始化应用程序

在模块MOpenClose中，包括打开和关闭应用程序时的代码。

代码语言：javascript复制

'每次启动应用程序时初始化
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

在启动应用程序时，首先删除所有已经存在或可能存在的工具栏。然后，初始化所有全局变量，这里的两个全局变量，一个用于存放加载宏的完整路径，一个用于指明加载宏是否在关闭过程中。接着，查找用户接口工作簿，如果找到则继续运行程序，否则显示错误信息并退出应用程序。

创建工具栏

初始化应用程序完成后，构建工具栏。

代码语言：javascript复制

'为应用程序创建命令栏
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

所构建的工具栏如下图1所示，为应用程序提供了四种功能。

图1

Microsoft为Excel 2007及以后的版本引入了新的功能区界面，因此原先创建的自定义菜单或工具栏将会出现在功能区“加载项”选项卡中，如上图1所示。

打开并初始化时间输入工作簿

下面的程序读取用于接口设置的工作表中的数据并在接口工作簿中进行使用：

代码语言：javascript复制

'将设置应用到时间输入工作簿的所有工作表
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

MakeWorksheetSettings过程遍历指定工作簿中的每个工作表，将已定义好的设置应用到这些工作表中。

在接口工作簿初始化完成后，运行过程ResetAppProperties过程，确保Excel应用程序相关的属性均被设置为默认值。

代码语言：javascript复制

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

excel microsoft 工作

0 人点赞