Question

我需要一些方法来更新我的员工之间共享的excel插件，以便每个人都不必下载＆amp;手动安装。

我已经google了，看到我们可以将文件写入操作系统文件系统，因此任务最终会编写新版本的插件，即.xlam文件，以覆盖自身。

我不知道如何做到这一点。如果你有，请分享！谢谢！

Answer 1

我不知道是否有一种不那么粗暴的做法，但我已经“入侵”了涉及SendKeys的解决方案。哎呀，我知道。希望其他人能有更好的解决方案。

我记得，你需要在覆盖.xla（m）文件之前卸载一个插件，而我找不到纯粹使用内置对象的方法。

下面的代码基本上卸载了加载项，调用“加载项”对话框并使用SendKeys将其从列表中删除，然后再复制新文件并重新安装加载项。

根据您的具体情况对其进行修改 - 当然，这取决于您的用户安全设置是否足够低以使其运行。

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

Answer 2

我使用reversioning addin-manager来执行此操作：基本上它是一个小的xla / xlam，它永远不会更改安装在每个用户计算机上的那些。它检查网络共享以获取最新版本的真实插件，并将其打开，就像它是普通的工作簿一样：这样可以为用户加载真正的插件。

有一个可下载的工作示例，您可以自定义here

Answer 3

另一种选择，这就是我所做的。

关键点。 Addin版本是＆＃34;某些数字＆＃34;，文件名始终相同。必须知道安装目录

当被问及当前的插件时，会查看是否有新版本可用。我通过一个系统来实现这一点，该系统的文件名为＆＃34;更新＆＃34;和版本号作为代码中的const。

建立I后我们可以更新，我去获取更新＆＃34;包＆＃34; - 就我而言，我使用的是安装程序和小型vb.net应用程序。如果你不能这样做，那么你可能想要启动PPT或单词的失败，并使用它完成安装。

接下来关闭自己，或要求用户关闭Excel。

现在我们需要做的就是将新插件保存在旧插件上，并使用相同的文件名。

告诉用户更新后，他们应该重新打开Excel，关闭安装程序。

这对我很有用 - 尽管您需要记住编号系统，文件名以及代码的工作方式。

以下是代码位杂乱的主要内容，但可能会帮助你。

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

如何让VBA excel addin .xlam通过远程更新的.xlam取代自己？

3 个答案: