工程代码_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 TypePrivate Type RefsInfo    refs(100) As RefInfo        dic As Object    Count As LongEnd TypeSub 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    NextEnd 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    NextEnd Function