VBA实用小程序：使用VBA代码安装或卸载加载宏

excelperfect

下面的程序整理自jkp-ads.com，使用VBA代码来自动安装或者移除指定的加载宏。

Dim vReply As Variant

Dim AddInLibPath As String

Dim CurAddInPath As String

'修改为你想要安装的加载宏名称

Const sAppName As String = '完美Excel'

Const sFilename As String = sAppName &'.xlam'

'用于设置的注册表键

Const sRegKey As String = 'FXLNameMgr'

'安装加载宏

Sub Setup()

    vReply =MsgBox('这将安装 '& sAppName & vbNewLine & _

    '到你的默认加载项文件夹.'& vbNewLine & vbNewLine & '继续?', vbYesNo, sAppName &' 安装')

    If vReply= vbYes Then

        On Error Resume Next

       Workbooks(sFilename).Close False

        If Application.OperatingSystem Like '*Win*' Then

           CurAddInPath = ThisWorkbook.Path & '\' & sFilename

           If Right(Application.UserLibraryPath, 1) <>Application.PathSeparator Then

                AddInLibPath =Application.UserLibraryPath & '\' & sFilename

           Else

               AddInLibPath = Application.UserLibraryPath & sFilename

           End If

        Else

           CurAddInPath = ThisWorkbook.Path & ':' & sFilename

            '语法与Win不同

           AddInLibPath = Application.UserLibraryPath & sFilename

        End If

        On Error Resume Next

       FileCopy CurAddInPath, AddInLibPath

        If Err.Number <> 0 Then

           SomeThingWrong

           Exit Sub

        End If

        With AddIns.Add(FileName:=AddInLibPath)

       .Installed = True

        End With

    Else

    vReply =MsgBox(prompt:='安装已取消',Buttons:=vbOKOnly, Title:=sAppName & ' 安装')

    End If

End Sub

'错误信息

Sub SomeThingWrong()

    If Application.OperatingSystemLike '*Win*' Then

       vReply = MsgBox(prompt:='在加载宏复制到加载项文件夹期间' &vbNewLine _

        &'发生错误:'_

        &vbNewLine & vbNewLine & Application.UserLibraryPath _

        &vbNewLine & vbNewLine & '你可以通过手动复制文件 ' &sFilename & ' 安装加载宏'_

        &vbNewLine & sAppName & ' 到你的目录中并使用Excel功能区中的加载项工具安装该加载宏.'_

        &vbNewLine & vbNewLine & '不要按''''确定'''',首先从Windows资源管理器中复制.'_

        &vbNewLine & '它使你有机会按ALT+TAB返回Excel以阅读此文本.'_

        &vbNewLine, Buttons:=vbOKOnly, Title:=sAppName & ' 安装')

    Else

       vReply = MsgBox(prompt:='在该加载宏复制到你的加载项目录期间发生错误:'& vbNewLine _

        &vbNewLine & vbNewLine & Application.UserLibraryPath _

        &vbNewLine & vbNewLine & '你可以通过复制 ' &sFilename & ' 手动安装加载项 '_

        &vbNewLine & sAppName & ' 到这个目标并使用Excel功能区中的加载项工具安装该加载宏.'_

        &vbNewLine & vbNewLine & '先不要按''''确定'''',先在Finder中复制.' _

        &vbNewLine & '它使你有机会按ALT+TAB返回Excel以阅读此文本.'_

        &vbNewLine, Buttons:=vbOKOnly, Title:=sAppName & ' 安装')

    End If

End Sub

'移除加载宏

Sub Uninstall()

    vReply =MsgBox('这将从系统中移除加载宏 '& sAppName & vbNewLine & _

    vbNewLine& vbNewLine & '继续?',vbYesNo, sAppName & ' 安装')

    If vReply= vbYes Then

        If Application.OperatingSystem Like '*Win*' Then

           CurAddInPath = ThisWorkbook.Path & '\' & sFilename

           If Right(Application.UserLibraryPath, 1) <>Application.PathSeparator Then

               AddInLibPath = Application.UserLibraryPath & '\' &sFilename

           Else

               AddInLibPath = Application.UserLibraryPath & sFilename

           End If

        Else

           CurAddInPath = ThisWorkbook.Path & ':' & sFilename

           AddInLibPath = Application.UserLibraryPath & sFilename

        End If

        On Error Resume Next

       Workbooks(sFilename).Close False

        Kill AddInLibPath

       DeleteSetting sRegKey

       MsgBox '这个 '& sAppName & ' 已经从你的计算机中移除.'_

        &vbNewLine & '为了完成移除操作, 请在对话框中选取 '& sAppName _

        &vbNewLine & ' 并确认删除',vbInformation + vbOKOnly

        Application.CommandBars(1).FindControl(ID:=943,recursive:=True).Execute

    End If

End Sub

注意，包含本代码的工作簿应与加载宏文件放置在同一文件夹中。在移除加载宏时，会弹出“加载宏”对话框，需要手动取消相应加载宏前面的复选，才能彻底移除该加载宏。