[求助]多文档时遇到的问题，想了多天解决不了，恳请高手们帮忙
如题Set doc = ThisDrawing.Application.Documents("Drawing1.dwg")
这句如果在VB中怎么表示，好像在VB中应改成
Set doc = Acadapp.Application.Documents("Drawing1.dwg")
但是会出错，希望大家不遗余力帮我解决一个困扰多时的难题
查了很多资料，并且尝试解决了好几天仍不得解
故来论坛上请高手指点一二，谢谢！！
自定义函数
函数是修改mccad大大的，可是在VB中运行就不行！提示：实时错误，对象item 的方法‘
IAcadDocuments'失败
Set objCurDoc = acadapp.Application.Documents.Item(App.Path & "\Gallery\" & CurDocname & ".dwg")的下面一句
Set objCurDoc = acadapp.Application.Documents.Open(App.Path & "\Gallery\" & CurDocname & ".dwg")
到是可以，但我不需要那样的功能，我需要获得打开的CAD文档。
'复制到一张图纸上
Public Sub CopyFromOuterDwg(CurDocname, NewDocname As String)
' 第一张图
Dim objCurDoc As AcadDocument
Set objCurDoc = acadapp.Application.Documents.Item(App.Path & "\Gallery\" & CurDocname & ".dwg")
'Set objCurDoc = acadapp.Application.Documents.Open(App.Path & "\Gallery\" & CurDocname & ".dwg")
' 新图形
Dim objNewDoc As AcadDocument
Set objCurDoc = acadapp.Application.Documents.Item(App.Path & "\Gallery\" & NewDocname & ".dwg")
'Set objNewDoc = acadapp.Application.Documents.Open(App.Path & "\Gallery\" & NewDocname & ".dwg")
objNewDoc.Activate
'Set objNewDoc = acadapp.Application.ActiveDocument
' 将外部图形的实体复制到当前图形
Set ssetobj = CreateSelectionSet
ssetobj.Select acSelectionSetAll
'ssetObj.SelectOnScreen
acadapp.ActiveDocument.CopyObjects ssArray(ssetobj), objCurDoc.ModelSpace
objCurDoc.Regen acAllViewports
' 关闭打开的图形
objNewDoc.Close
End Sub
如果是新建的可以试下
Acadapp.Application.Documents(Acadapp.Application.Documents.Count - 1)
不是新建的，我是打开图库中的图
所以不知道该怎么解决
VBA中就能用，在VB中咋就不能用了呢
我的想法是这样的
先打开图库中的3个图，分别操作后，放到一张图上，也就是放到一个文档上
就是在这句时不能实现
Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery\" & NewDocname & ".dwg")
VBA中是这样的一句：Set doc = Thisdrawing.Application.Documents("Drawing1.dwg")
请高手帮忙，谢谢了！
Set doc = Acadapp.Documents("Drawing1.dwg")
首先谢谢楼上两位的热心解答
不过我试过
Set doc = Acadapp.Documents("Drawing1.dwg")
这句还是会提示那样的错误
真不知道怎么解决，请大家用你们的智慧帮我解答下，不甚感激！
当前文档先保存在一个变量里
然后用三个doc变量保存你打开的文档
试了下，没有成功，能给个具体点的代码么？谢谢了
把你的代码贴上看看吧，VBA没有装了，：）
或者你可以试下ObjectDBX？
'打开到一张图纸上
Public Sub CopyFromOuterDwg(CurDocname As String, NewDocname As String)
' 打开第一张图
Dim objCurDoc As AcadDocument
Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery\" & CurDocname & ".dwg")
' 打开一个新图形
Dim objNewDoc As AcadDocument
Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery\" & NewDocname & ".dwg")
Set objNewDoc = acadapp.Application.ActiveDocument
' 将外部图形的实体复制到当前图形
Set ssetobj = CreateSelectionSet
ssetobj.Select acSelectionSetAll
acadapp.ActiveDocument.CopyObjects ssArray(ssetobj), objCurDoc.ModelSpace
objCurDoc.Regen acAllViewports
' 关闭打开的图形
objNewDoc.Close (False)
End Sub
'返回包含于选择集中每一项目的变体数,参数:一选择集
Public Function ssArray(ss As AcadSelectionSet)
Dim retVal() As AcadEntity, k As Long
ReDim retVal(0 To ss.Count - 1)
For k = 0 To ss.Count - 1
Set retVal(k) = ss.Item(k)
Next
ssArray = retVal
End Function
'建立选择集
'示例:acadapp.activedocument.ModelSpace.AddRegion ssArray(mySS)
Public Function CreateSelectionSet(Optional ByVal SSetName As String) As AcadSelectionSet
On Error Resume Next
acadapp.ActiveDocument.SelectionSets(SSetName).Delete
Set CreateSelectionSet = acadapp.ActiveDocument.SelectionSets.Add(SSetName)
End Function
试下吧
'打开到一张图纸上
Public Sub CopyFromOuterDwg(CurDocname As String, NewDocname As String)
' 打开第一张图
Dim objCurDoc As AcadDocument
Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery" & CurDocname & ".dwg")
' 打开一个新图形
Dim objNewDoc As AcadDocument
Set objNewDoc = acadapp.Application.Documents(App.Path & "\Gallery" & NewDocname & ".dwg")
' 将外部图形的实体复制到当前图形
Set ssetobj = CreateSelectionSet(objNewDoc, "test")
ssetobj.Select acSelectionSetAll
objNewDoc.CopyObjects ssArray(ssetobj), objCurDoc.ModelSpace
objCurDoc.Regen acAllViewports
' 关闭打开的图形
objNewDoc.Close (False)
End Sub
'返回包含于选择集中每一项目的变体数,参数:一选择集
Public Function ssArray(ss As AcadSelectionSet)
Dim retVal() As AcadEntity, k As Long
ReDim retVal(0 To ss.Count - 1)
For k = 0 To ss.Count - 1
Set retVal(k) = ss.Item(k)
Next
ssArray = retVal
End Function
'建立选择集
Public Function CreateSelectionSet(ByVal Doc As AcadDocument, ByVal SSetName As String) As AcadSelectionSet
On Error Resume Next
Doc.SelectionSets(SSetName).Delete
Set CreateSelectionSet = Doc.SelectionSets.Add(SSetName)
End Function
页:
[1]