以编程方式将加载项宏添加到快速访问工具栏

我有一个用于格式化 Excel 报告的宏。该宏需要在许多不同的工作簿上运行，因为每天都会生成报告并将其保存到新文件中。这已经在我的个人作业簿中了。我现在需要分享这个宏。

我的计划是将该加载项放在我的本地加载项文件夹中。在那里进行任何更新并运行一个例程，将插件复制到网络位置并将其设置为只读和隐藏。其他用户的本地计算机上不会有该插件，因此当他们重新启动 Excel 时，更新就会生效。

我创建了一个“虚拟安装程序工作簿”，它将从网络位置加载插件，并确保用户不会将插件复制到本地计算机。

我希望这个虚拟工作簿向快速访问工具栏添加一个用于加载项的按钮，这样我就不必向用户解释该过程。我还没有找到一种方法可以在保留用户当前的 UI 设置的同时执行此操作。我想大多数用户都没有对他们的用户界面进行太多调整，但我宁愿不为弄乱某人的用户界面负责。

我仍在学习如何使用 VBA，并且它正在部署在网络环境中，这对我来说也有点新鲜。

Note:

• CommonSizeAR 代码位于 Common Size AR.xlam 的 module1 中，DeployAddIn 位于模块 2 中。
• Workbook_Open 存储在 Common Size AR installer.xlsm 的“此工作簿”中。

Private Sub deployAddIn()

    Dim strAddinDevelopmentPath As String
    Dim strAddinPublicPath As String 

    strAddinDevelopmentPath = "C:\AddIns" & Application.PathSeparator
    strAddinPublicPath = "W:\NetworkDrive" & Application.PathSeparator
    Application.DisplayAlerts = False

    With ThisWorkbook
        .Save
        On Error Resume Next
        SetAttr strAddinPublicPath & .Name, vbNormal
        On Error GoTo 0
        .SaveCopyAs Filename:=strAddinPublicPath & .Name
        SetAttr strAddinPublicPath & .Name, vbReadOnly + vbHidden
    End With

    Application.DisplayAlerts = True

End Sub

Private Sub workbook_open()

    Dim Result As Integer

    Result = MsgBox("Would you like to install the Common Size AR Add-in?", _
      vbYesNo + vbQuestion, "Install?")

    If Result = vbNo Then
        Application.ThisWorkbook.Close SaveChanges:=False
        Exit Sub
    End If

    On Error Resume Next
    AddIns("Common Size AR").Installed = False
    On Error GoTo ErrorHandler1

    AddIns.Add Filename:="W:\NetworkDrive\Common Size AR.xlam", Copyfile:=False
    AddIns("Common Size AR").Installed = True
    MsgBox "Add-in Installed!", vbOKOnly + vbInformation, "Done!"
    Application.ThisWorkbook.Close SaveChanges:=False

    Exit Sub

ErrorHandler1:
    MsgBox "Install Failed! Please let Developer know", vbOKOnly + vbCritical, "Error!"
    Exit Sub 

End Sub

运行子添加菜单 - 这将创建添加选项卡，添加菜单 使用按钮运行removemenu sub，它将接受添加 菜单选项卡和按钮消失

Option Explicit

Sub AddMenu()
Dim Mycbar As CommandBar, Mycontrol As CommandBarControl, Mypopup As CommandBarPopup

Application.ScreenUpdating = False
RemoveMenu ' call remove routine to ensure only one menu in place

Set Mycbar = CommandBars.Add _
(Name:="TO's Menubar", Position:=msoBarBottom, Temporary:=False)
' create new commandbar (menu bar)

Set Mycontrol = Mycbar.Controls.Add(msoControlButton)
' create new commandbar control (button type) on custom menu
With Mycontrol
.Caption = "Smiley Yes/No" ' mouseover text
.Tag = "Smiley" ' used for identification
.OnAction = "MySub" ' macro called with control
.FaceId = 59 ' appearance, based on built-in faces
End With

Set Mypopup = Mycbar.Controls.Add(msoControlPopup)
' create new commandbar control (popup menu type) on custom menu
With Mypopup
.BeginGroup = True ' start new group
.Caption = "TO Menu Items" ' mouseover text
.Tag = "TOMenu" ' used for identification
End With

'============================================================================
'Add various sub-menu items to the popup control

Set Mycontrol = Mypopup.Controls.Add(msoControlButton)
With Mycontrol
.Caption = "Text Converter" ' menu item description
.Tag = "Text Converter" ' used for identification
.OnAction = "TextCon" ' macro called with control
.FaceId = 59 ' appearance, based on built-in faces
End With

'===============================================================================

Mycbar.Visible = True
Application.ScreenUpdating = True

Set Mycbar = Nothing 'release memory
Set Mycontrol = Nothing
Set Mypopup = Nothing

End Sub

Sub RemoveMenu()
Dim Mycbar As CommandBar

On Error Resume Next ' in case its already gone
Set Mycbar = CommandBars("TO's Menubar")
Mycbar.Delete
Set Mycbar = Nothing 'release memory

End Sub

Sub MySub()
Dim ans As Integer

ans = MsgBox("Do you want to remove the custom menu?", vbYesNo, "TO Custom Menu")
If ans = 6 Then RemoveMenu

End Sub

'text converter
Sub TextCon()
Dim ocell As Range, ans As String

ans = Application.InputBox("Type in Letter" & vbCr & _
"(L)owercase, (U)ppercase, (S)entence, (T)itles ")

If ans = "" Then Exit Sub

For Each ocell In Selection.SpecialCells(xlCellTypeConstants, 2)
Select Case UCase(ans)
Case "L": ocell = LCase(ocell.Text)
Case "U": ocell = UCase(ocell.Text)
Case "S": ocell = UCase(Left(ocell.Text, 1)) & _
LCase(Right(ocell.Text, Len(ocell.Text) - 1))
Case "T": ocell = Application.WorksheetFunction.Proper(ocell.Text)
End Select
Next
End Sub