如何让 VBA excel 插件 .xlam 用远程更新的 .xlam 替换自身？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/11577158/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How to get VBA excel addin .xlam to replace itself by a remote updated .xlam?
提问by Nam G VU
I need some way to update an excel addin shared among my staffs so as everyone don't have to download & install it manually.
我需要一些方法来更新我的员工共享的 excel 插件，这样每个人都不必手动下载和安装它。
I have googled and see that we can write file to the OS file system so the task ends up with writing the new-version addin, i.e. the .xlam file, to overwrite itself.
我用谷歌搜索，看到我们可以将文件写入操作系统文件系统，因此任务最终以编写新版本插件（即 .xlam 文件）来覆盖自身。
I have no idea on how to do this. If you do have ones, please share! Thank you!
我不知道如何做到这一点。如果你有的话，请分享！谢谢！
回答by Widor
I don't know if there's a less crude way of doing it, but I have "hacked" a solution that involves SendKeys. Yuck, I know. Hopefully someone else will have a better solution.
我不知道是否有一种不那么粗糙的方法，但我已经“破解”了一个涉及SendKeys. 哎呀，我知道。希望其他人会有更好的解决方案。
As I recall, you need to uninstall an addin before you can overwrite the .xla(m) file and I couldn't find a way to do this purely using built-in objects.
我记得，您需要先卸载插件才能覆盖 .xla(m) 文件，我找不到纯粹使用内置对象的方法。
The code below basically uninstalls the add-in, invokes the "Add-ins" dialog box and uses SendKeysto remove it from the list, before copying the new file and reinstalling the add-in.
下面的代码基本上是卸载加载项，调用“加载项”对话框并用于SendKeys将其从列表中删除，然后复制新文件并重新安装加载项。
Amend it for your circumstances - it will depend on your users having their security settings low enough to let it run, of course.
根据您的情况修改它 - 当然，这取决于您的用户的安全设置是否足够低以使其运行。
Sub UpdateAddIn()
Dim fs As Object
Dim Profile As String
If Workbooks.Count = 0 Then Workbooks.Add
Profile = Environ("userprofile")
Set fs = CreateObject("Scripting.FileSystemObject")
AddIns("MyAddIn").Installed = False
Call ClearAddinList
fs.CopyFile "\SourceOfLatestAddIn\MyAddIn.xla", Profile & "\Application Data\Microsoft\AddIns\", True
AddIns.Add Profile & "\Application Data\Microsoft\AddIns\MyAddIn.xla"
AddIns("MyAddIn").Installed = True
End Sub
Sub ClearAddinList()
Dim MyCount As Long
Dim GoUpandDown As String
'Turn display alerts off so user is not prompted to remove Addin from list
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do
'Get Count of all AddIns
MyCount = Application.AddIns.Count
'Create string for SendKeys that will move up & down AddIn Manager List
'Any invalid AddIn listed will be removed
GoUpandDown = "{Up " & MyCount & "}{DOWN " & MyCount & "}"
Application.SendKeys GoUpandDown & "~", False
Application.Dialogs(xlDialogAddinManager).Show
Loop While MyCount <> Application.AddIns.Count
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
回答by Charles Williams
I use a reversioning addin-manager to do this: basically its a small xla/xlam that never changes thats installed on each users machine. It checks a network share for the latest version of the real addin(s) and opens it as if it was an ordinary workbook: this has the effect of loading the real Addin(s) for the user.
我使用恢复插件管理器来做到这一点：基本上它是一个小的 xla/xlam，它永远不会改变安装在每台用户机器上的内容。它检查最新版本的真实插件的网络共享并将其打开，就像它是一个普通的工作簿：这具有为用户加载真实插件的效果。
There is a downloadable working example which you can customise here
有一个可下载的工作示例，您可以在此处进行自定义
回答by Ross
Another option, this is what I do.
另一种选择，这就是我所做的。
Key points. Addin version is "some number", file name is always the same. Installation directory must be known
关键点。插件版本是“一些数字”，文件名总是相同的。必须知道安装目录
When asked, the current addin, looks to see if a new version is available. I do this via a system that has a version number in the file name of the "update" and a version number as a const in the code.
当被询问时，当前的插件会查看是否有新版本可用。我通过一个在“更新”的文件名中有一个版本号和一个版本号作为代码中的常量的系统来做到这一点。
Having established I we can update, I go and get the update "package" - in my case I am using an installer and a small vb.net app. If you cant do this then you might want to spin up an insatnce of PPT or word, and use that complete the install.
确定我可以更新后，我去获取更新“包” - 就我而言，我使用的是安装程序和一个小型 vb.net 应用程序。如果你不能这样做，那么你可能想要启动一个 PPT 或 word 文件，然后使用它完成安装。
Next close yourself, or ask the user to close Excel.
接下来关闭自己，或要求用户关闭 Excel。
Now all we need to do is save the new addin over the old one, with the same file name.
现在我们需要做的就是使用相同的文件名将新插件保存在旧插件上。
Tell the user its updated, and they should re-open Excel, close the install program.
告诉用户它更新了，他们应该重新打开 Excel，关闭安装程序。
This works well for me - although you need to remember the numbering system , in the file name and how that code works.
这对我来说很有效 - 尽管您需要记住文件名中的编号系统以及该代码的工作方式。
The below is the main guts of the code bit messy, but might help you out.
下面是代码有点乱的主要内容，但可能会帮助你。
Private Sub CommandButton1_Click()
Dim RetVal As Long
MsgBox "To install the update, follow the installer programes directions." & vbNewLine & vbNewLine & _
"You will need to then closed down and restart Excel.", vbInformation + vbOKOnly, "::::UPDATE TRS:::::"
RetVal = Shell(gsDataBase1 & "\" & gsUpdatefolder & "\" & GetUpdateFileName(), 1)
ThisWorkbook.Close
Unload Me
End Sub
Private Sub CommandButton2_Click()
gbInUpdate = False
Unload Me
End Sub
Private Sub UserForm_Initialize()
Me.lbNew = GetServerVersion2
Me.lbCurrent.Caption = gcVersionNumber
'CheckVersionNumbers
End Sub
'''This method might be better, but is quite slow.
Public Sub GetServerVersion()
Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.Namespace(gsDataBase1 & "\" & gsUpdatefolder)
For Each strFileName In objFolder.Items
Me.lbNew.Caption = objFolder.GetDetailsOf(strFileName, 11)
Next
Set objshell = Nothing
End Sub
Public Function IsNewer() As Boolean
Dim curVer As Long
Dim newVer As Long
On Error GoTo Catch
curVer = CLng(Left(Replace(Me.lbCurrent, ".", ""), 2))
newVer = CLng(Left(Replace(Me.lbNew, ".", ""), 2))
If curVer < newVer Then
IsNewer = True
Else
IsNewer = False
End If
Exit Function
Catch:
IsNewer = False
End Function
Private Function GetServerVersion2() As String
On Error GoTo LEH
Dim strDocPath As String
Dim strCurrentFile As String
strDocPath = gsDataBase1 & "\" & gsUpdatefolder & "\"
strCurrentFile = Dir(strDocPath & "*.*")
'gets last file - randomly? should onl;y be one anyway!
'Do While strCurrentFile <> ""
GetServerVersion2 = Right(strCurrentFile, 11)
GetServerVersion2 = Left(GetServerVersion2, 7)
'Loop
Exit Function
LEH:
GetServerVersion2 = "0.Error"
End Function
'Basiclly a coop of GetSeverVerion, but just get the file name so the exe can be called by the shell operation under the update button
''seems clumbys, but works!
Private Function GetUpdateFileName() As String
On Error GoTo LEH
Dim strDocPath As String
Dim strCurrentFile As String
strDocPath = gsDataBase1 & "\" & gsUpdatefolder & "\"
GetUpdateFileName = Dir(strDocPath & "*.*")
Exit Function
LEH:
GetUpdateFileName = "0.Error"
End Function
