excel - 如何让 VBA excel 插件 .xlam 用远程更新的 .xlam 替换自己？

Question

我需要一些方法来更新我的员工之间共享的 excel 插件，这样每个人都不必手动下载和安装它。

我用谷歌搜索，发现我们可以将文件写入操作系统文件系统，因此任务最终以编写新版本插件（即 .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

我使用一个还原插件管理器来做到这一点：基本上它是一个小的 xla/xlam，它永远不会改变安装在每个用户机器上的那个。它检查网络共享中最新版本的真实插件并将其打开，就好像它是一个普通的工作簿一样：这具有为用户加载真实插件的效果。

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

Answer 3

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

关键点。插件版本是“某个数字”，文件名始终相同。必须知道安装目录

当被问到时，当前插件会查看是否有新版本可用。我通过一个系统来执行此操作，该系统在“更新”的文件名中具有版本号，并且在代码中具有作为 const 的版本号。

确定我可以更新后，我去获取更新“包”——在我的情况下，我使用的是安装程序和一个小的 vb.net 应用程序。如果你不能这样做，那么你可能想要启动一个 PPT 或 word 文件，然后使用它来完成安装。

接下来关闭自己，或要求用户关闭 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