excelperfect

下面的程序整理自jkp-ads.com，使用VBA代碼來自動(dòng)安裝或者移除指定的加載宏。

Dim vReply As Variant

Dim AddInLibPath As String

Dim CurAddInPath As String

'修改為你想要安裝的加載宏名稱

Const sAppName As String = '完美Excel'

Const sFilename As String = sAppName &'.xlam'

'用于設(shè)置的注冊(cè)表鍵

Const sRegKey As String = 'FXLNameMgr'

'安裝加載宏

Sub Setup()

    vReply =MsgBox('這將安裝 '& sAppName & vbNewLine & _

    '到你的默認(rèn)加載項(xiàng)文件夾.'& vbNewLine & vbNewLine & '繼續(xù)?', 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

'錯(cuò)誤信息

Sub SomeThingWrong()

    If Application.OperatingSystemLike '*Win*' Then

       vReply = MsgBox(prompt:='在加載宏復(fù)制到加載項(xiàng)文件夾期間' &vbNewLine _

        &'發(fā)生錯(cuò)誤:'_

        &vbNewLine & vbNewLine & Application.UserLibraryPath _

        &vbNewLine & vbNewLine & '你可以通過手動(dòng)復(fù)制文件 ' &sFilename & ' 安裝加載宏'_

        &vbNewLine & sAppName & ' 到你的目錄中并使用Excel功能區(qū)中的加載項(xiàng)工具安裝該加載宏.'_

        &vbNewLine & vbNewLine & '不要按''''確定'''',首先從Windows資源管理器中復(fù)制.'_

        &vbNewLine & '它使你有機(jī)會(huì)按ALT+TAB返回Excel以閱讀此文本.'_

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

    Else

       vReply = MsgBox(prompt:='在該加載宏復(fù)制到你的加載項(xiàng)目錄期間發(fā)生錯(cuò)誤:'& vbNewLine _

        &vbNewLine & vbNewLine & Application.UserLibraryPath _

        &vbNewLine & vbNewLine & '你可以通過復(fù)制 ' &sFilename & ' 手動(dòng)安裝加載項(xiàng) '_

        &vbNewLine & sAppName & ' 到這個(gè)目標(biāo)并使用Excel功能區(qū)中的加載項(xiàng)工具安裝該加載宏.'_

        &vbNewLine & vbNewLine & '先不要按''''確定'''',先在Finder中復(fù)制.' _

        &vbNewLine & '它使你有機(jī)會(huì)按ALT+TAB返回Excel以閱讀此文本.'_

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

    End If

End Sub

'移除加載宏

Sub Uninstall()

    vReply =MsgBox('這將從系統(tǒng)中移除加載宏 '& sAppName & vbNewLine & _

    vbNewLine& vbNewLine & '繼續(xù)?',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 '這個(gè) '& sAppName & ' 已經(jīng)從你的計(jì)算機(jī)中移除.'_

        &vbNewLine & '為了完成移除操作, 請(qǐng)?jiān)趯?duì)話框中選取 '& sAppName _

        &vbNewLine & ' 并確認(rèn)刪除',vbInformation + vbOKOnly

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

    End If

End Sub

注意，包含本代碼的工作簿應(yīng)與加載宏文件放置在同一文件夾中。在移除加載宏時(shí)，會(huì)彈出“加載宏”對(duì)話框，需要手動(dòng)取消相應(yīng)加載宏前面的復(fù)選，才能徹底移除該加載宏。