WordVBA函数:删除所有的VBA组件

在备份后，可以导入相应代码。

主要用于代码在不同电脑中转移，以及分享代码。

这个包括多个函数组，具体如下：

Private Sub 导入所有的VBA组件()

    On Error GoTo ErrorHandler

    Dim strPath As String
    strPath = SelectedTheFolder(strIniPath)
    If strPath = "" Then Exit Sub

    Dim objDic As Variant
    objDic = FileFullNamesInFolder(strPath)
    If IsEmpty(objDic) Then Exit Sub

    Dim strName As Variant
    Dim strFileName As String
    Dim strFileFullName As String
    Dim strFileShortName As String
    Dim strExtend As String

    Dim strExisted As String
    strExisted = ExistedThreeComponentsObjectsNames()

    For Each strName In objDic
        strFileFullName = strName
        strFileName = Replace(strName, strPath, "")
        strFileShortName = Split(strFileName, ".")(0)
        strExtend = Split(strFileName, ".")(1)

        ' 排除 LibCore 和 ThisDocument 组件，这是手工导入
        If strFileShortName <> "LibCore" And strFileShortName <> "ThisDocument" And strExtend <> "frx" Then
            If InStr(1, strExisted, "|" & strFileShortName & "|") > 0 Then
                Select Case MsgBox("当前已经存在名称为：" & strFileName & " 的组件,是否要覆盖？", vbYesNoCancel + vbDefaultButton2)
                    Case vbYes
                        RemoveVBComponent strFileShortName
                        Application.VBE.ActiveVBProject.VBComponents.Import strFileFullName
                    Case vbNo
                        On Error Resume Next
                        Application.VBE.ActiveVBProject.VBComponents(strFileShortName).Name = "Pre_" & strFileShortName
                        Application.VBE.ActiveVBProject.VBComponents.Import strFileFullName
                        On Error GoTo ErrorHandler
                    Case vbCancel
                        ' 取消操作，继续下一个组件
                End Select
            Else
                Application.VBE.ActiveVBProject.VBComponents.Import strFileFullName
            End If
        End If
    Next

    MsgBox "所有组件已成功导入！", vbInformation, "提示"
    Exit Sub

ErrorHandler:
    MsgBox "导入组件时发生错误：" & Err.Description, vbExclamation, "错误"
End Sub

' 获取当前 VBA 工程中所有模块、类和表单的名称，主要这三类！
Private Function ExistedThreeComponentsObjectsNames() As String
    Dim objVBComponent As VBComponent
    Dim strAllVBComponentName As String
    strAllVBComponentName = "|"

    For Each objVBComponent In Application.VBE.ActiveVBProject.VBComponents
        Select Case objVBComponent.Type
            Case vbext_ct_StdModule, vbext_ct_ClassModule, vbext_ct_MSForm
                strAllVBComponentName = strAllVBComponentName & objVBComponent.Name & "|"
        End Select
    Next

    ExistedThreeComponentsObjectsNames = strAllVBComponentName
End Function

' 删除指定名称的 VBA 组件
Private Sub RemoveVBComponent(strVBComponentName As String)
    On Error Resume Next
    Dim objVBComponent As VBComponent
    Set objVBComponent = Application.VBE.ActiveVBProject.VBComponents(strVBComponentName)
    If Not objVBComponent Is Nothing Then
        Application.VBE.ActiveVBProject.VBComponents.Remove objVBComponent
    End If
    On Error GoTo 0
End Sub

' 选择文件夹并返回路径
Public Function SelectedTheFolder(Optional strInitialFileName As String = "D:\") As String
    Dim strFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = strInitialFileName
        .Title = "选择一个文件夹："
        If .Show <> -1 Then Exit Function
        strFolder = .SelectedItems(1)
    End With

    SelectedTheFolder = strFolder & Application.PathSeparator
End Function