我正在寻找一个宏，它将为用户安装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后无法找到它的错误关闭。
现在我的理解是，下面代码行的第二个（false）变量基本上表示不应该将addin复制到AddIns目录，而应该保留在共享位置。
.AddIns.Add "Filepath to addin in shared location", False
有关为什么Excel期望插件位于用户默认文件夹中的任何想法？
答案 0 :(得分：0)
我会尝试的。请查看代码中的注释。
此工作簿
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