在利用VBAProject来共用VBA代码里介绍了使用VBAProject管理代码的方法，但是有一个不方便的地方，如果想把一个做好的功能（引用了一些其他工程代码）发送给其他人使用，就需要把所引用的工程代码复制到一起，再发给其他人，这样手动处理有些麻烦。
在VBA操作VBA——VBA工程对象中介绍过，VBA是可以去操作VBA工程对象的，所以，只要能够正确找到某个文件所直接引用以及间接引用的工程，把所引用的工程代码复制就可以。
我在实现这个功能的时候，有一个前提（这个可以看个人习惯）：
- 每个被引用的功能都有个模块MAPI，里面主要是写一些对外公开的函数
- MTest模块、ThisWorkbook模块以及以Sheet开头的会被忽略
程序主要的逻辑就是递归的查找某个VBProject所引用的工程，将工程对象的FullPath记录到一个字典中，并用bRemove记录是否是直接引用的，只有直接引用的工程在复制完代码后才需要断开引用。
找到所有引用的工程之后，将每个工程的代码复制过来就可以了：
代码语言：javascript复制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
