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

Question

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

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

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

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

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

注意：

• CommonSizeAR 代码位于 Common Size AR.xlam 的模块 1 中，DeployAddIn 位于模块 2 中。
• Workbook_Open存储在通用大小AR安装程序.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:NetworkDriveCommon 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

Answer 1

运行子添加菜单 - 这将创建添加 Ins 选项卡，添加菜单 使用按钮运行删除菜单子，它将接受添加 菜单选项卡和按钮

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