microsoft excel正在等待其他某个应用程序_一起学Excel专业开发17：Excel工时报表与分析系统开发（2）——创建特定应用加载宏...

学习Excel技术，关注微信公众号：

excelperfect

在《一起学Excel专业开发13：Excel工时报表与分析系统开发(1)》中，我们创建了一个基于Excel的工时报表与分析系统(PETRAS)，这里会为该系统创建特定应用加载宏。

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

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

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

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

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

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

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

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

7.允许用户关闭PETRAS程序

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

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

声明全局常量和变量

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

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

启动和初始化应用程序

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

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

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

图1

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

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

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

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

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

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

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

有兴趣的朋友可以在完美Excel公众号底部发送消息：

工时表加载宏

下载示例对照研究。