VBA快速提取引用工程的代码

Private Type RefInfo
    r As Reference
    bRemove As Boolean '是否需要断开引用，有的可能是递归间接引用的
End Type

Private Type RefsInfo
    refs(100) As RefInfo
    
    dic As Object
    Count As Long
End Type

Sub GetReferencesModule()
    Dim ref As RefsInfo
    
    Set ref.dic = VBA.CreateObject("Scripting.Dictionary")

    '记录引用的工程
    RGetReferences ActiveWorkbook.VBProject, ref, True
    If ref.Count = 0 Then
        MsgBox "没有引用的工程。"
        Exit Sub
    End If
    
    On Error Resume Next
    ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule).Name = "MAPI"
    On Error GoTo 0
    
    Dim i As Long
    For i = 0 To ref.Count - 1
        GetAllModules ActiveWorkbook.VBProject, ref.refs(i).r, ActiveWorkbook.VBProject.VBComponents("MAPI")
        
        '断开引用
        If ref.refs(i).bRemove Then ActiveWorkbook.VBProject.References.Remove ref.refs(i).r
    Next
End Sub

'递归查找，引用的工程可能还会引用其他，只记录引用的工程名称
Function RGetReferences(p As VBProject, ref As RefsInfo, bRemove As Boolean) As Long
    Dim r As Reference
    Dim i As Long
    
    For Each r In p.References
        If r.Type = vbext_rk_Project Then
            If Not ref.dic.Exists(r.FullPath) Then
                Set ref.refs(ref.Count).r = r
                ref.refs(ref.Count).bRemove = bRemove
                
                ref.dic(r.FullPath) = ref.Count
                ref.Count = ref.Count + 1
                '递归
                RGetReferences Application.VBE.VBProjects(r.Name), ref, False
            End If
        End If
    Next
    
End Function

'VBP        目标VBProject
'r          引用
Function GetAllModules(VBP As VBProject, r As Reference, MAPI As VBComponent)
    Dim p As VBProject
    Set p = Application.VBE.VBProjects(r.Name)
    
    Dim cadd As VBComponent
    Dim c As VBComponent
    Dim cs As VBComponents
    
    Set cs = p.VBComponents
    Dim str As String
    For Each c In cs
        If c.Name <> "ThisWorkbook" And c.Name <> "MTest" And VBA.Left$(c.Name, 5) <> "Sheet" Then
            '获取组件的代码
            If c.Name = "MAPI" Then
                '声明部分
                str = c.CodeModule.Lines(1 + 1, c.CodeModule.CountOfDeclarationLines) '不需要第一行的Option Explicit
                MAPI.CodeModule.InsertLines 1 + 1, str
                
                '代码部分
                str = c.CodeModule.Lines(c.CodeModule.CountOfDeclarationLines + 1, c.CodeModule.CountOfLines) '不需要第一行的Option Explicit
                MAPI.CodeModule.InsertLines MAPI.CodeModule.CountOfDeclarationLines + 1, str
            Else
                str = c.CodeModule.Lines(1 + 1, c.CodeModule.CountOfLines) '不需要第一行的Option Explicit
                Set cadd = VBP.VBComponents.Add(c.Type)
                cadd.Name = c.Name
                cadd.CodeModule.InsertLines 1 + 1, str
            End If
        End If
    Next
End Function