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

在利用VBAProject来共用VBA代码里介绍了使用VBAProject管理代码的方法，但是有一个不方便的地方，如果想把一个做好的功能（引用了一些其他工程代码）发送给其他人使用，就需要把所引用的工程代码复制到一起，再发给其他人，这样手动处理有些麻烦。

在VBA操作VBA——VBA工程对象中介绍过，VBA是可以去操作VBA工程对象的，所以，只要能够正确找到某个文件所直接引用以及间接引用的工程，把所引用的工程代码复制就可以。

我在实现这个功能的时候，有一个前提（这个可以看个人习惯）：

每个被引用的功能都有个模块MAPI，里面主要是写一些对外公开的函数
MTest模块、ThisWorkbook模块以及以Sheet开头的会被忽略

程序主要的逻辑就是递归的查找某个VBProject所引用的工程，将工程对象的FullPath记录到一个字典中，并用bRemove记录是否是直接引用的，只有直接引用的工程在复制完代码后才需要断开引用。

找到所有引用的工程之后，将每个工程的代码复制过来就可以了：

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