excel分两个独立窗口_一起学Excel专业开发21：Excel工时报表与分析系统开发（3）——自定义用户界面...

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

excelperfect

本文接着前两篇文章：

一起学Excel专业开发19：基于Excel的独立式应用程序开发

一起学Excel专业开发20：Excel工时报表与分析系统开发(3)——自定义用户界面

注：这里介绍的自定义用户界面是针对Excel 2003及以前的版本的，虽然Excel 2007及以后的版本将用户界面由原来的菜单和工具栏修改成了现在的功能区，但仍能加载原来的自定义用户界面，只是将它们放置在功能区“加载项”选项卡中。

设置背景图片

最简便的方法是将应用程序工作簿中的一个工作表作为其“桌面”，向其中添加背景图片，并将工作簿最大化，设置工作表的显示属性使其显示范围扩大到整个Excel窗口，去除工作簿窗口中的控制框和最大最小化按钮，并使之处于保护状态。

代码如下：

'从加载宏复制背景工作簿到新建工作簿并进行配置Sub PrepareBackDrop()   Dim wkbBook As Workbook     '已经有背景对象吗?   If Not WorkbookAlive(gwbkBackDrop) Then        '查看是否已经有背景工作簿       Set gwbkBackDrop = Nothing       For Each wkbBook In Workbooks            IfwkbBook.BuiltinDocumentProperties("Title") = gsBACKDROP_TITLE Then                Set gwbkBackDrop = wkbBook                Exit For            End If       Next        If gwbkBackDrop Is Nothing Then            '从本工作簿中复制背景工作表            '到新工作簿中显示            wksBackdrop.Copy            Set gwbkBackDrop = ActiveWorkbook           gwbkBackDrop.BuiltinDocumentProperties("Title") =gsBACKDROP_TITLE       End If   End If    With gwbkBackDrop       .Activate         '选择包含背景图片的整个区域        '因此使用Zoom = True来调整合适的尺寸大小       .Worksheets(1).Range("rgnBackDrop").Select         '设置窗口查看选项来隐藏所有       With .Windows(1)            .WindowState = xlMaximized            .Caption = ""            .DisplayHorizontalScrollBar = False            .DisplayVerticalScrollBar = False            .DisplayHeadings = False            .DisplayWorkbookTabs = False             '缩放所选区域适合屏幕            .Zoom = True       End With         '阻止选择或编辑背景中的任意单元格       With .Worksheets(1)           .Range("ptrCursor").Select            .ScrollArea =.Range("ptrCursor").Address            .EnableSelection = xlNoSelection            .Protect DrawingObjects:=True,UserInterfaceOnly:=True       End With         '保护背景工作簿        '删除控制菜单       .Protect Windows:=True       .Saved = True   End WithEnd Sub

PrepareBackDrop过程调用了自定义函数WorkbookAlive，该函数的作用及代码如下：

'测试指定的工作簿对象变量是否指向有效的工作簿'无须将变量设置为Nothing即可关闭该工作簿Function WorkbookAlive(ByRef wbkTest AsWorkbook) As Boolean    On Error Resume Next    If Not wbkTest Is Nothing Then        '如果工作簿已被关闭,则将失败        '保留WorkbookAlive的值为False       WorkbookAlive = wbkTest.Sheets(1).Name <> ""   End IfEnd Function

基于工作表和基于用户窗体的用户接口

独立式应用程序主要有两种类型的用户接口：

1.工作表型的数据输入接口

2.用户窗体

基于工作表的用户接口被设计为最大化地利用Excel的单元格编辑功能，如自动补充完整、数据验证、条件格式等。如果应用程序使用基于工作表的用户接口，则应该将工作表作为主要的数据录入界面和显示报表的界面，而对话框应只用于少量的任务和向导程序。

基于用户窗体的接口主要使用Excel的计算和分析功能而不是单元格的编辑功能。用户窗体具有功能简单、控制性强等特点，可以有效地减少用户错误，使应用程序具有更好的健壮性。如果应用程序使用基于用户窗体的接口，则工作表只应用于显示报表。

在决定采用何种样式的用户接口时，应该考虑用户可能会在应用程序的什么地方花时间，是提供丰富的编辑功能更好还是提供强大的控制功能更好。

自定义命令栏

对于Excel 2003及以前的版本来说，大多数独立式应用程序都包括一套自已的菜单或工具栏，用于调用相应的功能操作。如本示例所示：

图1

下面是建立图1所示菜单结构的代码：

'设置命令栏Sub SetUpMenus()   Dim cbCommandBar As CommandBar   Dim oPopup As CommandBarPopup   Dim oButton As CommandBarButton     '隐藏所有工具栏   On Error Resume Next   For Each cbCommandBar In Application.CommandBars       cbCommandBar.Visible = False       cbCommandBar.Enabled = False   Next   Application.CommandBars(gsMENU_BAR).Delete   On Error GoTo 0     '创建菜单栏   Set cbCommandBar = Application.CommandBars.Add(gsMENU_BAR, , True, True)     '文件菜单   Set oPopup = cbCommandBar.Controls.Add(msoControlPopup)   With oPopup       .Caption = "文件(&F)"         '文件 > 新建       Set oButton = .Controls.Add(msoControlButton)       With oButton            .Caption = "新建合并(&N)..."            .BeginGroup = True            .FaceId = 18            .ShortcutText = "Ctrl+N"            .OnAction = "MenuFileNew"            Application.OnKey "^N","MenuFileNew"            Application.OnKey "^n","MenuFileNew"       End With         '文件 > 打开       Set oButton = .Controls.Add(msoControlButton)       With oButton            .Caption = "打开(&O)..."            .BeginGroup = False            .FaceId = 23            .ShortcutText = "Ctrl+O"            .OnAction ="MenuFileOpen"            Application.OnKey "^O","MenuFileOpen"            Application.OnKey "^o","MenuFileOpen"       End With         '文件 > 关闭       Set oButton = .Controls.Add(msoControlButton)       With oButton            .Caption = "关闭(&C)"            .BeginGroup = False            .FaceId = 106            .OnAction ="MenuFileClose"            .Enabled = False       End With         '文件 > 保存        '使用标准的保存按钮       Set oButton = .Controls.Add(msoControlButton, 3)       With oButton            .BeginGroup = True            .Enabled = False       End With         '文件 > 另存为        '使用标准的另存为按钮       Set oButton = .Controls.Add(msoControlButton, 748)       With oButton            .BeginGroup = False            .Enabled = False       End With         '文件 > 退出       Set oButton = .Controls.Add(msoControlButton)       With oButton            .Caption = "退出(&E)"            .BeginGroup = True            .OnAction ="MenuFileExit"       End With   End With     '处理菜单   Set oPopup = cbCommandBar.Controls.Add(msoControlPopup)   With oPopup       .Caption = "处理(&P)"         '处理 > 合并       Set oButton = .Controls.Add(msoControlButton)       With oButton            .Caption = "合并工时表(&C)"            .BeginGroup = True            .OnAction ="MenuConsolidate"            .Enabled = False       End With   End With     '帮助菜单   Set oPopup = cbCommandBar.Controls.Add(msoControlPopup)   With oPopup       .Caption = "帮助(&H)"         '帮助 > 关于       Set oButton = .Controls.Add(msoControlButton)       With oButton            .Caption = "关于PETRAS报表(&A)"            .BeginGroup = True            .OnAction ="MenuHelpAbout"       End With   End With    cbCommandBar.Visible = TrueEnd Sub

下面是自定义菜单项调用实现相应功能的代码：

'处理文件->新建菜单项'关闭任何现有的结果工作簿'创建一个新的工作簿'然后启动合并程序Sub MenuFileNew()    '在创建一个新工作簿前,关闭现有的结果工作簿   If Not gwbkResults Is Nothing Then MenuFileClose     '如果仍然存在,则取消关闭   If Not gwbkResults Is Nothing Then Exit Sub     '按照模板创建一个新的结果工作簿   Set gwbkResults = Workbooks.Add(ThisWorkbook.Path & "\"& gsRESULTS_TEMPLATE)     '启用文件菜单   EnableDisableMenus True     '运行合并程序   ConsolidateWorkbooksEnd Sub  '处理文件->打开菜单项'关闭任何现有的结果工作簿'询问要打开的新工作簿的名称'检查它是否是结果工作簿,然后将其打开Sub MenuFileOpen()   Dim vFile As Variant     '在创建新工作簿前关闭现有的结果工作簿   If Not gwbkResults Is Nothing Then MenuFileClose     '如果仍然存在, 则取消关闭   If Not gwbkResults Is Nothing Then Exit Sub    vFile = Application.GetOpenFilename("PETRAS结果工作簿(*.xls*),*.xls*", , "打开结果工作簿",, False)    If vFile = False Then Exit Sub     '检查文件以获取可识别的自定义文档属性   If FileHasYesProperty(vFile, gsPETRAS_RESULTS) Then       '如果是则打开并启用关闭,保存和另存为菜单命令项       Set gwbkResults = Workbooks.Open(vFile)       EnableDisableMenus True   Else       MsgBox "文件'" & vFile & "' 不是PETRAS结果工作簿.",vbOKOnly, gsAPP_TITLE    End IfEnd Sub  '处理文件->关闭菜单项'也可被文件->新建, 文件->打开和文件->退出调用'确认关闭并可选择保存/另存为Sub MenuFileClose()   Dim lErr As Long     '检查结果对象是否指向有效工作簿   If Not WorkbookAlive(gwbkResults) Then       Set gwbkResults = Nothing       Exit Sub   End If     '有修改吗?如果有,提示保存   If Not gwbkResults.Saved Then        '提示保存并处理选择       Select Case MsgBox("保存修改到'" & gwbkResults.Name & "'?", vbYesNoCancel,gsAPP_TITLE)       Case vbYes            '是新的或只读工作簿?            If Len(gwbkResults.Path) = 0 OrgwbkResults.ReadOnly Then                '新的或只读工作簿, 因此必须"另存为".                 '激活该工作簿并显示Excel标准的'另存为'对话框                gwbkResults.Activate                 On Error Resume Next                If NotApplication.Dialogs(xlDialogSaveAs).Show Then Exit Sub                lErr = Err.Number                On Error GoTo 0                If lErr = 0 Then                    '所有保存都OK,关闭该工作簿                    gwbkResults.Close False                    Set gwbkResults = Nothing                     '禁用按键菜单项                    EnableDisableMenus False                End If            Else                '保存                On Error Resume Next                gwbkResults.Save                lErr = Err.Number                On Error GoTo 0                 If lErr = 0 Then                    '保存OK, 关闭工作簿                    gwbkResults.Close False                    Set gwbkResults = Nothing                     '禁用按键菜单英                    EnableDisableMenus False                Else                    '保存失败                    MsgBox "不能保存到工作簿 '"& gwbkResults.Name & "'.", vbOKOnly, gsAPP_TITLE                End If            End If        Case vbNo            '用户不想保存, 只是关闭            gwbkResults.Close False            Set gwbkResults = Nothing             '禁用按键菜单项            EnableDisableMenus False        Case vbCancel            '没有任何操作       End Select   Else        '没有修改, 可以关闭       gwbkResults.Close False       Set gwbkResults = Nothing   End IfEnd Sub  '处理文件->退出菜单项Sub MenuFileExit()   Dim wkbWorkbook As Workbook     '关闭现有的结果工作簿   If Not gwbkResults Is Nothing Then MenuFileClose     '如果仍然存在, 取消关闭, 不退出   If Not gwbkResults Is Nothing Then Exit Sub     '恢复用户设置   RestoreExcelSettings     '如果不在调式模式   If Not gbDebugMode Then         '... 将所有工作簿标记为已保存 ...       For Each wkbWorkbook In Workbooks            wkbWorkbook.Saved = True       Next         '... 退出Excel       Application.Quit   End IfEnd Sub  '处理->合并工时表菜单项Sub MenuConsolidate()   Dim wksData As Worksheet     '完整性检查   If gwbkResults Is Nothing Then       MsgBox "在使用此菜单前,请打开或创建新的结果工作簿.",vbOKOnly, gsAPP_TITLE       Exit Sub   End If     '确认替换现有数据   IfgwbkResults.Names("rngConsolidate").RefersToRange.Rows.Count > 2Then       If MsgBox("这将替换现有的工时表结果数据并清除其下方的所有行."& vbLf & "确定要这么做吗?",vbYesNo, gsAPP_TITLE) = vbNo Then Exit Sub         '清除现有数据区域及其下的所有内容，仅保留标题       Set wksData =gwbkResults.Names("rngdataarea").RefersToRange.Parent       wksData.Range("rngConsolidate").Offset(1,0).Resize(65534).ClearContents   End If    ConsolidateWorkbooksEnd Sub '帮助->关于PETRAS菜单项Sub MenuHelpAbout()   MsgBox "PETRAS由StephenBullen和RobBovey" & vbLf & _          "为Addison-Wesley出版的图书""ProfessionalExcel Development""编写.", _            vbOKOnly, gsAPP_TITLEEnd Sub

上述代码中，多处调用了EnableDisableMenus过程和ConsolidateWorkbooks过程。

EnableDisableMenus过程的作用和代码如下：

'启用/禁用按键菜单项,具体取决于应用程序上下文'当背景工作簿处于活动状态时,大多数功能都被禁用Sub EnableDisableMenus(ByVal bEnable AsBoolean)    '启用/禁用按键菜单项   With Application.CommandBars(gsMENU_BAR)       .FindControl(ID:=3, Recursive:=True).Enabled = bEnable       .FindControl(ID:=748, Recursive:=True).Enabled = bEnable       .Controls("文件(&F)").Controls("关闭(&C)").Enabled= bEnable       .Controls("处理(&P)").Controls("合并工时表(&C)").Enabled= bEnable   End With     '启用/禁用相关联的快捷键   If bEnable Then       Application.OnKey "^s"       Application.OnKey "^S"   Else       Application.OnKey "^s", ""       Application.OnKey "^S", ""   End IfEnd Sub

ConsolidateWorkbooks过程用来合并所选择的工作簿：

'从源工时表工作簿中获取数据Sub ConsolidateWorkbooks()   Dim vFiles As Variant   Dim lFile As Long   Dim lTotal As Long   Dim lCount As Long   Dim lRows As Long   Dim pcCache As PivotCache   Dim wkbTimesheet As Workbook   Dim wksData As Worksheet     '询问选择进行合并的多个文件列表   vFiles = Application.GetOpenFilename("PETRAS工时表工作簿(*.xls*), *.xls*", , "选择要合并的工作簿",, True)     '如果取消则退出    '当请求一个多选列表时,如果确定或取消,将返回一个数组    '因此可以测试数组(确定)的情况：   If Not IsArray(vFiles) Then Exit Sub     '获取要写入的工作表并清除目标数据区域   Set wksData =gwbkResults.Names("rngDataArea").RefersToRange.Parent   wksData.Range("rngDataArea").Offset(1, 0).ClearContents    Application.ScreenUpdating = False     '在处理过程中关闭事件    '因此不会收到任何Workbook_Activate事件    '或者正在打开的工作簿中的Workbook_Open事件   Application.EnableEvents = False     '关闭事件后,必须有一些错误处理,以确保总是可将它们重新打开   On Error GoTo ErrHandler     '初始化处理计数器   lCount = 0   lTotal = UBound(vFiles) - LBound(vFiles) + 1     '遍历所选择的文件    '检查是否是工时表文件    '如果是,打开并将数据复制到合并表   For lFile = LBound(vFiles) To UBound(vFiles)       lCount = lCount + 1        Application.StatusBar = "读取 "& lTotal & " 个文件中的第" & lCount & " 个."         '检查文件以获取可识别的自定义文档属性       If FileHasYesProperty(vFiles(lFile), gsPETRAS_TIMESHEET) Then            '是工时表文件, 打开工作簿            Set wkbTimesheet =Workbooks.Open(vFiles(lFile), UpdateLinks:=False, ReadOnly:=True)            wkbTimesheet.Worksheets(1).Unprotect             '复制工时表区域, 不包括标题行            WithwkbTimesheet.Worksheets(1).Range("tblTimeSheet")                '按日期排序, 使它们有序并在表顶部                .Sort key1:=.Cells(1, 3),order1:=xlAscending, header:=xlYes, Orientation:=xlTopToBottom                 '已输入了多少行                lRows =Application.WorksheetFunction.CountA(.Columns(3)) - 1                 '如果发现任何内容,则复制                If lRows > 0 Then                    .Offset(1,0).Resize(lRows).Copy                End If            End With             If lRows > 0 Then                '将数据粘贴到结果工作表                WithwksData.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)                    .Offset(0, 1).PasteSpecialxlPasteValues                     '添加文件名到Source列                    .Resize(lRows, 1).Value = vFiles(lFile)                End With            End If             '关闭工作簿            wkbTimesheet.Close False       End If   Next     '重新打开事件,并恢复报错   Application.EnableEvents = True   On Error GoTo 0     '如果没有获取任何数据,则使用一些虚拟结果填充结果区域    '否则, 在刷新时数据透视表将报错   With wksData.Range("rngDataArea")       If .Rows.Count = 1 Then            MsgBox "选择的工作簿不包含任何工时表数据,",vbOKOnly, gsAPP_TITLE             '字段是SourceFile, Consultant, EndDate, Day, Client, Project, Activity,Start Time, Stop Time, Total Hours            .Offset(1, 0).Value = Array("无","没有数据",0, 0, "没有数据","没有数据","没有数据",0, 0, 0)       End If   End With    wksData.Range("A1").Select   wksData.Range("rngConsolidate").Offset(0, 1).EntireColumn.AutoFit    Application.StatusBar = "刷新数据透视表"     '刷新工作簿中可能存在的所有数据透视表   For Each pcCache In gwbkResults.PivotCaches       pcCache.Refresh   Next    Application.StatusBar = False     '重新计算所有内容(以防设置为手动重算)   Application.Calculate      Exit Sub ErrHandler:   Application.EnableEvents = True   MsgBox "合并工作簿时发生错误.错误是:"& vbLf & _          Err.Number & " - " & Err.Description, vbOKOnly,gsAPP_TITLEEnd Sub

在《一起学Excel专业开发17：Excel工时报表与分析系统开发(2)——创建特定应用加载宏》中，我们使用加载宏和模板创建每周工时表并将它们存储到工作区，ConsolidateWorkbooks过程用来获取这些工时表工作簿并将它们合并和分析。

处理与分析

独立式应用程序通常会充分利用Excel的数据处理、计算和分析等功能，各种数据的处理通常在程序的控制之下，借助于隐藏表来完成，只显示最终的结果。这样的处理方式，能够使计算效率最大化，并且不必担心用户是否理解各种用于计算的表格。

显示结果

Excel工作表非常适合显示报表和图表，正是由于Excel具有强大的报表展示功能，才使Excel开发具有较强的吸引力。

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

工时分析系统程序

下载示例工作簿研究。