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

Question

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

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

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

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

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

注意:

• CommonSizeAR 代码位于 Common Size AR.xlam 的模块 1 中，DeployAddIn 位于模块 2 中。
• Workbook_Open 存放在Common Size AR installer.xlsm的“this workbook”中。

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

Answer 1

运行 Sub add menu - 这将创建 add ins 选项卡，添加菜单使用按钮运行 removemenu 子，它将添加菜单选项卡和按钮离开

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