以编程方式安装加载项VBA

问题描述

我正在寻找创建一个宏，该宏将为用户安装一个加载项到excel功能区.我可以:

I'm looking to create a macro that'll install an add-in for the user to the excel ribbon. I'm upto:

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，该插件将不再显示在功能区中.

Once running the macro, the addin installs to the ribbon no problems. The issue is, once excel is closed down, the addin no longer shows in the ribbon.

似乎excel期望将外接程序复制到用户C:\ Documents and Settings \ Username \ Application Data \ Microsoft \ AddiIns文件夹中，因为它引发以下错误:启动excel后找不到该错误关闭.

It would appear that excel is expecting the addin to be copied into the users C:\Documents and Settings\Username\Application Data\Microsoft\AddiIns folder as it throws the error that it can't find it when starting excel after closing down.

现在，我的理解是，下面代码行的第二个(false)变量基本上表明该addin不应复制到AddIns目录，而应保留在共享位置.

Now my understanding is that the second (false) variable for the line of code below basically says that the addin shouldn't be copied to the AddIns directory and rather should stay in the shared location.

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

关于Excel为什么期望外接程序位于用户默认文件夹中的任何想法?

Any ideas on why Excel is expecting the addin to be in the users default folder?

推荐答案

我将尝试一下.请查看代码中的注释.

I'll give it a try. Please see comments in code.

此工作簿

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

这篇关于以编程方式安装加载项VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！