如何从 Excel 365 中的代码自定义功能区？

Question

我熟悉自定义 Excel 2013 及以下版本的 Excel 功能区所需的 VBA 例程。

尝试在 Excel 365 上打开文件时，我收到一条错误消息：

这是我使用的代码（适用于 Excel 2010）：

Sub CreateMenu()
    ' Delete the CommandBar if it exists already
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls("My Tool").Delete

    Set cControl = Application.CommandBars("Worksheet Menu Bar").Controls.Add
    With cControl
        .Caption = "My Tool"
        .Style = msoButtonCaption
    End With


End Sub

我应该如何修改代码以在 Excel 2010 和 Excel 365 版本上运行？

Answer 1

您的问题实际上是 IMO 的两个问题。

• 如何使代码适用于每个版本（区分 Office 版本）
• 如何使代码适用于 Office 365

我对 Office 365 功能区自定义做了一些研究，发现了一些我希望能有所帮助的东西。

自 Office365/2019 以来，区分 Office 版本变得更加困难。 You used to be able to just use Select Case Int(Application.Version) 加上 Case 11/14 等。但是现在 2016 年及以上的所有内容都只返回 Case 16。

我找到了a function to differentiate between Office Versions 以及一些CommandBars("Worksheet Menu Bar").Controls.Add 一直是"superseded by the new ribbon component of the Microsoft Office Fluent user interface." 的信息

我没有 Office 365 来测试如何修改您的代码，但是一旦您让该部分工作，您可以通过以下方式实施解决方案：

Private Sub Workbook_Open()

    If CStr(AppVersion) = 365 Then
    MsgBox "Office 365" 'Setup new code here for Office365
    ' See --> https://docs.microsoft.com/en-us/office/vba/api/office.commandbarcontrols.add
    ' Note: The use of CommandBars in some Microsoft Office applications has been superseded by the new ribbon component of the Microsoft Office Fluent user interface.
    ' For more information, see Overview of the Office Fluent ribbon.
    ' https://docs.microsoft.com/en-us/office/vba/library-reference/concepts/overview-of-the-office-fluent-ribbon
    Else
    MsgBox "Non-Office 365" ' Insert known working code here for older versions of Office/Excel or call seperate sub for Non-Office 365
    End If

End Sub

Private Function AppVersion() As Long
    'Test the Office application version
    'Written by Ken Puls (www.excelguru.ca)
    'https://www.excelguru.ca/blog/2019/02/11/check-the-application-version-in-modern-office/

    Dim registryObject As Object
    Dim rootDirectory As String
    Dim keyPath As String
    Dim arrEntryNames As Variant
    Dim arrValueTypes As Variant
    Dim x As Long

    Select Case Val(Application.Version)

        Case Is = 16
        'Check for existence of Licensing key
        keyPath = "Software\Microsoft\Office\" & CStr(Application.Version) & "\Common\Licensing\LicensingNext"
        rootDirectory = "."
        Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & rootDirectory & "\root\default:StdRegProv")
        registryObject.EnumValues &H80000001, keyPath, arrEntryNames, arrValueTypes

        On Error GoTo ErrorExit
        For x = 0 To UBound(arrEntryNames)
            If InStr(arrEntryNames(x), "365") > 0 Then
                AppVersion = 365
                Exit Function
            End If
            If InStr(arrEntryNames(x), "2019") > 0 Then
                AppVersion = 2019
                Exit Function
            End If
        Next x

        Case Is = 15
            AppVersion = 2013
        Case Is = 14
            AppVersion = 2010
        Case Is = 12
            AppVersion = 2007
        Case Else
            'Too old to bother with
            AppVersion = 0
    End Select

  Exit Function

ErrorExit:
    'Version 16, but no licensing key.  Must be Office 2016
    AppVersion = 2016

End Function