VBA实现xlam文件自动安装和加载功能

目录

先讲讲作用

第一步：构建安装（更新）类，实现对本xlam文档进行操作。

第二步：触发安装功能。

第三步：补全ThisVersion

第四步：安装及触发方法

本文主要讲解使用VBA实现xlam工具自动安装和加载功能。

先讲讲作用

1. 作用：我们在做很多工具的时候，需要迭代并且发给别人使用，我们并不能期望别人都懂一套复杂的更新替换流程，就像QQ更新一样，顶多是个双击运行就能更新才是最好的。
2. xlam文档是可以当成Excel加载项安装的，如下图1中的两项均为xlam加载项。

image.png

<图1>

再讲讲目标：

制作xlam文件，实现xlam能自动更新（或者安装）到某个特定位置，实现Excel在每次打开的时候自动加载，确保同一个Excel Application中不重复打开加载项。

步骤分解及实战代码：

第一步：构建安装（更新）类，实现对本xlam文档进行操作。

各个说明均在文档中。本代码非本人亲写，为引述别人的代码，对原作者表示感谢，因为实在记不起原文出处，故未贴引用链接，各位知道的请帖引用哈。

'原文出处：Https://???
'本代码为VBA的类模块文件，命名为：cAddInManager，知sir们可以自行重命名哦。
'此代码适用于VBA，请勿在VB.net中使用
Option Explicit

' Add-In 名称
Private add_in_name As String

' Add-In 版本
Private add_in_version As String

' Excel Add-In 文件路径
Private excel_add_in_folder_path As String

' 安装 Add-In
Sub Install(add_in_name_ As String, version As String)
    On Error GoTo ErrorHandler

    ' Init variables
    add_in_name = add_in_name_
    add_in_version = version
    excel_add_in_folder_path = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns"

    ' Exit if open from addin folder
    If ThisWorkbook.path = excel_add_in_folder_path Then Exit Sub

    ' If add_in 存在, 重装 or 不重装
    If AddInExists Then
        If MsgBox("此加载工具(" & add_in_name & ") 已经安装, 您想升级么?", vbYesNo) = vbYes Then

            ' 卸载Add-In
            '此句即为卸载功能，需要实现卸载功能的知sir可以直接增加Uninstall实现哦。
            Application.AddIns(add_in_name).Installed = False

            ' 安装Add-In
            Call InstallAddIn("update")

            ' 提醒更新成功
            MsgBox "恭喜您! 加载工具(" & add_in_name & ") 更新到版本 " & add_in_version, vbInformation
        End If

    ' If Add-In 尚不存在则安装
    Else
        If MsgBox("您愿意安装加载工具(" & add_in_name & ")吗?", vbYesNo) = vbYes Then

            ' 安装Add-In
            Call InstallAddIn

            ' 提醒安装成功
            MsgBox "恭喜您! 加载工具(" & add_in_name & " " & add_in_version & ") 完成安装!", vbInformation
        End If
    End If

    ' 关闭本文档
    ThisWorkbook.Close False
    Exit Sub
ErrorHandler:
    '错误的情况显示错误信息
    MsgBox Err.Description, vbCritical
    ThisWorkbook.Close False
End Sub

' 安装 Add-In
Private Sub InstallAddIn(Optional handle As String = "install")

    ' 复制  Add-In 到地址
    Dim add_in_path As String: add_in_path = excel_add_in_folder_path & "\" & add_in_name & ".xlam"
    With CreateObject("Scripting.FileSystemObject")
        .CopyFile ThisWorkbook.FullName, add_in_path, True
    End With

    ' If there are no active sheets, there will be an error when installing Add-In
    If Not HasActiveWorkbook Then Workbooks.Add

    ' Install
    Application.AddIns.Add(add_in_path).Installed = True
End Sub

' 如果Addin已经存在
Private Property Get AddInExists() As Boolean
    If add_in_name = "" Then AddInExists = False: Exit Property

    '对每一个Application的Add_in 轮询
    Dim add_in As AddIn
    For Each add_in In Application.AddIns
        If add_in.Title = add_in_name Then
            AddInExists = True
            Exit For
        End If
    Next
End Property

' 检查是否没有激活的文档
Private Property Get HasActiveWorkbook() As Boolean
    On Error GoTo ErrorHandler

    Dim Value As String: Value = ActiveSheet.Range("A1").Value
    HasActiveWorkbook = True

    Exit Property
ErrorHandler:
    HasActiveWorkbook = False
End Property

第二步：触发安装功能。

在xlam文档的ThisWorkBook模块中添加open事件代码：

image.png

<图2>

'此代码适用于VBA，请勿在VB.net中使用
Private Sub Workbook_Open()
    'Excel的正常弹窗功能=true
    Application.DisplayAlerts = True
    '安装
    With New cAddInManager
        .Install "工具名称", ThisVersion
    End With
End Sub

代码说明：

.Install 有两个参数，第一个为最后放入固定位置的文件的名称，第二个为工具版本信息

建议：文件名称 为 固定的名称，版本信息用于验证是否需要更新，即判断是新的或者更高的版本，不允许回退安装。因为回退安装可能会导致诸如注册表信息不兼容，算法更新不同步等情况。此处作极简处理，不深入探讨。

因为版本信息在Excel中应用多处，所以应该写在普通模块中。

第三步：补全ThisVersion

新建一个PublicBas_Version 模块，加入代码即可。

'此代码适用于VBA，请勿在VB.net中使用
Public Function ThisVersion() As String
    ThisVersion = "20210913"
End Function

第四步：安装及触发方法

把整个Excel文件另存为xlam格式文档。

image.png

<图3>

重新打开（双击）即可触发功能。再关闭已经打开的文档。直接打开一个新文档，或者打开其他文档时，便会自动打开该xlam文档。

验证是否触发的方式有三种

1. 是否有xlam中的相关功能被展示或者呈现出来；
2. 在图1所示处看是否有对应的加载项加载；
3. 在VBA编辑器中查看是否有对应文件的工程打开。

下一篇写怎么进一步打扮打扮我们的xlam文件，让她变得实用起来。

[打造个性化的Excel的工具栏（Ribbon）界面]