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

fanjy

发布于 2019-11-07 16:56:28

1.9K0

发布于 2019-11-07 16:56:28

文章被收录于专栏：完美Excel完美Excel

本文接着前两篇文章：

一起学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 With
End 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 If
End 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 = True
End 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
 
    '运行合并程序
   ConsolidateWorkbooks
End 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 If
End 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 If
End 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 If
End 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
 
   ConsolidateWorkbooks
End Sub
 
'帮助->关于PETRAS菜单项
Sub MenuHelpAbout()
   MsgBox "PETRAS由StephenBullen和RobBovey" & vbLf & _
          "为Addison-Wesley出版的图书""ProfessionalExcel Development""编写.", _
            vbOKOnly, gsAPP_TITLE
End 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 If
End 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_TITLE
End Sub

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

处理与分析

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

显示结果

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

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

工时分析系统程序

下载示例工作簿研究。

本文参与腾讯云自媒体分享计划，分享自微信公众号。

原始发表：2019-11-01，如有侵权请联系 cloudcommunity@tencent.com 删除

excel

报表

本文分享自完美Excel 微信公众号，前往查看

如有侵权，请联系 cloudcommunity@tencent.com 删除。

本文参与腾讯云自媒体分享计划，欢迎热爱写作的你一起参与！

excel

报表

登录后参与评论

0 条评论

热度

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

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

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐