excel - 以编程方式安装加载项 VBA

Question

我正在创建一个宏，为用户安装 Excel 功能区的加载项。我准备好了:

Private Sub Workbook_Open()

On Error Resume Next
Application.AddIns("Name of Addin").Installed = False
On Error GoTo 0

With Application
    .AddIns.Add "Filepath to addin in shared location", False
    .AddIns("Name of Addin").Installed = True
End With

ThisWorkbook.Close False

End Sub

运行宏后，插件安装到功能区就没有问题。问题是，一旦关闭 Excel，该插件就不再显示在功能区中。

看起来 Excel 期望将插件复制到用户 C:\Documents and Settings\Username\Application Data\Microsoft\AddiIns 文件夹中，因为它会抛出错误，在之后启动 excel 时找不到它倒闭了。

现在我的理解是，下面代码行的第二个(假)变量基本上表示加载项不应复制到 AddIns 目录，而应保留在共享位置。

.AddIns.Add "Filepath to addin in shared location", False

关于为什么 Excel 期望插件位于用户默认文件夹中的任何想法？

Answer 1

我会尝试一下。请参阅代码中的注释。

本工作簿

Option Explicit
 '
 '---------------------------------------------------------------------
 ' Purpose : Call for installation as an addin if not installed
 '---------------------------------------------------------------------
 '
Private Sub Workbook_Open()

    Dim AddinTitle As String, AddinName As String
    Dim XlsName As String

    AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    XlsName = AddinTitle & ".xlsm"
    AddinName = AddinTitle & ".xla"

     'check the addin's not already installed in UserLibraryPath
    If Dir(Application.UserLibraryPath & AddinName) = Empty Then
         'ask if user wants to install now
        If MsgBox("Install " & AddinTitle & _
        " as an add-in?", vbYesNo, _
        "Install?") = vbYes _
        Then
            Run "InstallAddIn"
        End If
    Else
        If ThisWorkbook.Name = XlsName Then
            Run "ReInstall"
        End If
    End If

End Sub

 '
 '---------------------------------------------------------------------
 ' Purpose : Actuate the addin, add custom controls
 '---------------------------------------------------------------------
 '
Private Sub Workbook_AddinInstall()
    Run "AddButtons"
End Sub
 '
 '---------------------------------------------------------------------
 ' Purpose : Deactivate the addin, remove custom controls
 '---------------------------------------------------------------------
 '
Private Sub Workbook_AddinUninstall()
    Run "RemoveButtons"
End Sub

模块

Option Explicit
 '
 '---------------------------------------------------------------------
 ' Purpose : Convert .xls file to .xla, move it to
 ' addins folder, and install as addin
 '---------------------------------------------------------------------
 '
Private Sub InstallAddIn()

    Dim AddinTitle As String, AddinName As String
    Dim XlsVersion As String, MessageBody As String

    With ThisWorkbook
        AddinTitle = Left(.Name, Len(.Name) - 4)
        AddinName = AddinTitle & ".xlam"
        XlsVersion = .FullName '< could be anywhere

         'check the addin's not installed in
         'UserLibraryPath (error handling)
        If Dir(Application.UserLibraryPath & AddinName) = Empty Then

            .IsAddin = True '< hide workbook window

             'move & save as .xla file
            .SaveAs Application.UserLibraryPath & AddinName, 55

             'go thru the add-ins collection to see if it's listed
            If Listed Then
                 'check this addins checkbox in the addin dialog box
                AddIns(AddinTitle).Installed = True '<--Error happening if .xlam format
            Else
                 'it's not listed (not previously installed)
                 'add it to the addins collection
                 'and check this addins checkbox
                AddIns.Add(ThisWorkbook.FullName, True) _
                .Installed = True
            End If

             'inform user...
            MessageBody = AddinTitle & " has been installed - " & _
            "to access the tools available in" & _
            vbNewLine & _
            "this addin, you will find a button in the 'Tools' " & _
            "menu for your use"
            If BooksAreOpen Then '< quit if no other books are open
                .Save
                MsgBox MessageBody & "...", , AddinTitle & _
                " Installation Status..."
            Else
                If MsgBox(MessageBody & " the" & vbNewLine & _
                "next time you open Excel." & _
                "" & vbNewLine & vbNewLine & _
                "Quit Excel?...", vbYesNo, _
                AddinTitle & " Installation Status...") = vbYes Then
                    Application.Quit
                Else
                    .Save
                End If
            End If
        End If

    End With
End Sub


'---------------------------------------------------------------------
 ' Purpose : Checks if this addin is in the addin collection
 '---------------------------------------------------------------------
 '
Private Function Listed() As Boolean

    Dim Addin As Addin, AddinTitle As String

    Listed = False
    With ThisWorkbook
        AddinTitle = Left(.Name, Len(.Name) - 4)
        For Each Addin In AddIns
            If Addin.Title = AddinTitle Then
                Listed = True
                Exit For
            End If
        Next
    End With
End Function


'---------------------------------------------------------------------
 ' Purpose : Check if any workbooks are open
 ' (this workbook & startups excepted)
 '---------------------------------------------------------------------
 '
Private Function BooksAreOpen() As Boolean
     '
    Dim Wb As Workbook, OpenBooks As String

     'get a list of open books
    For Each Wb In Workbooks
        With Wb
            If Not (.Name = ThisWorkbook.Name _
            Or .Path = Application.StartupPath) Then
                OpenBooks = OpenBooks & .Name
            End If
        End With
    Next
    If OpenBooks = Empty Then
        BooksAreOpen = False
    Else
        BooksAreOpen = True
    End If
End Function


'---------------------------------------------------------------------
 ' Purpose : Replace addin with another version if installed
 '---------------------------------------------------------------------
 '
Private Sub ReInstall()

    Dim AddinName As String

    With ThisWorkbook
        AddinName = Left(.Name, Len(.Name) - 4) & ".xla"

         'check if 'addin' is already installed
         'in UserLibraryPath (error handling)
        If Dir(Application.UserLibraryPath & AddinName) = Empty Then

             'install if no previous version exists
            Call InstallAddIn

        Else
             'delete installed version & replace with this one if ok
            If MsgBox(" The target folder already contains " & _
            "a file with the same name... " & _
            vbNewLine & vbNewLine & _
            " (That file was last modified on: " & _
            Workbooks(AddinName) _
            .BuiltinDocumentProperties("Last Save Time") & ")" & _
            vbNewLine & vbNewLine & vbNewLine & _
            " Would you like to replace the existing file with " & _
            "this one? " & _
            vbNewLine & vbNewLine & _
            " (This file was last modified on: " & _
            .BuiltinDocumentProperties("Last Save Time") & ")", _
            vbYesNo, "Add-in Is In Place - " & _
            "Confirm File Replacemant...") = vbYes Then
                Workbooks(AddinName).Close False
                Kill Application.UserLibraryPath & AddinName
                Call InstallAddIn
            End If
        End If
    End With
End Sub

 '---------------------------------------------------------------------
 ' Purpose : Convert .xla file to .xls format
 ' and move it to default file path
 '---------------------------------------------------------------------
 '
Private Sub RemoveAddIn()

    Dim AddinTitle As String, AddinName As String
    Dim XlaVersion As String

    Application.ScreenUpdating = False

    With ThisWorkbook
        AddinTitle = Left(.Name, Len(.Name) - 4)
        AddinName = AddinTitle & ".xla"
        XlaVersion = .FullName

         'check the 'addin' is not already removed
         'from UserLibraryPath (error handling)
        If Not Dir(Application.UserLibraryPath & AddinName) = Empty _
        Then

            .Sheets(1).Cells.ClearContents '< cleanup
            Call RemoveButtons

             'move & save as .xls file
            .SaveAs Application.DefaultFilePath & _
            "\" & AddinTitle & ".xls"

            Kill XlaVersion '< delete .xla version

             'uncheck checkbox in the addin dialog box
            AddIns(AddinTitle).Installed = False
            .IsAddin = False '< show workbook window
            .Save

             'inform user and close
            MsgBox "The addin '" & AddinTitle & "' has been " & _
            "removed and converted to an .xls file." & _
            vbNewLine & vbNewLine & _
            "Should you later wish to re-install this as " & _
            "an addin, open the .xls file which" & _
            vbNewLine & "can now be found in " & _
            Application.DefaultFilePath & _
            " as: '" & .Name & "'"
            .Close
        End If

    End With

    Application.ScreenUpdating = True
End Sub


'---------------------------------------------------------------------
 ' Purpose : Add addin control buttons
 '---------------------------------------------------------------------
 '
Private Sub AddButtons()

     'change 'Startups...' to suit
    Const MyControl As String = "Startups..."
     'change 'Manage Startups' to suit
    Const MyControlCaption As String = "Manage Startups"

    Dim AddinTitle As String, Mybar As Object

    AddinTitle = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)

    Call RemoveButtons

    On Error GoTo ErrHandler
    Set Mybar = Application.CommandBars("Worksheet Menu Bar") _
    .Controls("Tools").Controls _
    .Add(Type:=msoControlPopup, before:=13)
     '
    With Mybar
        .BeginGroup = True
        .Caption = MyControl
         '-------------------------------------------------------------
        .Controls.Add.Caption = MyControlCaption
        .Controls(MyControlCaption).OnAction = "ShowStartupForm"
         '-------------------------------------------------------------
        With .Controls.Add
            .BeginGroup = True
            .Caption = "Case " & AddinTitle
        End With
        .Controls("Case change " & AddinTitle).OnAction = "ULCase.UpperMacro"
         '-------------------------------------------------------------
        .Controls.Add.Caption = "Remove " & AddinTitle
        .Controls("Remove " & AddinTitle).OnAction = "Module1.RemoveAddIn"
         '-------------------------------------------------------------
    End With
    Exit Sub

ErrHandler:
    Set Mybar = Nothing
    Set Mybar = Application.CommandBars("Tools") _
    .Controls.Add(Type:=msoControlPopup, before:=13)
    Resume Next
End Sub
 '
 '---------------------------------------------------------------------
 ' Purpose : Remove addin control buttons
 '---------------------------------------------------------------------
 '
Private Sub RemoveButtons()
     '
     'change 'Startups...' to suit
    Const MyControl As String = "Startups..."
    On Error Resume Next
    With Application
        .CommandBars("Tools").Controls(MyControl).Delete
        .CommandBars("Worksheet Menu Bar") _
        .Controls("Tools").Controls(MyControl).Delete
    End With
End Sub