[求助]多文档时遇到的问题，想了多天解决不了，恳请高手们帮忙

zdm860114

如题

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

雪山飞狐_lzh

如果是新建的可以试下

Acadapp.Application.Documents(Acadapp.Application.Documents.Count - 1)

zdm860114

不是新建的，我是打开图库中的图

所以不知道该怎么解决

VBA中就能用，在VB中咋就不能用了呢

我的想法是这样的

先打开图库中的3个图，分别操作后，放到一张图上，也就是放到一个文档上

就是在这句时不能实现

Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery\" & NewDocname & ".dwg")

VBA中是这样的一句：Set doc = Thisdrawing.Application.Documents("Drawing1.dwg")
请高手帮忙，谢谢了！

sailorcwx

Set doc = Acadapp.Documents("Drawing1.dwg")

zdm860114

首先谢谢楼上两位的热心解答

不过我试过

Set doc = Acadapp.Documents("Drawing1.dwg")

这句还是会提示那样的错误

真不知道怎么解决，请大家用你们的智慧帮我解答下，不甚感激！

雪山飞狐_lzh

当前文档先保存在一个变量里

然后用三个doc变量保存你打开的文档

zdm860114

lzh741206发表于2009-5-21 12:31:00当前文档先保存在一个变量里然后用三个doc变量保存你打开的文档

试了下，没有成功，能给个具体点的代码么？谢谢了

雪山飞狐_lzh

把你的代码贴上看看吧，VBA没有装了，：）

或者你可以试下ObjectDBX？

zdm860114

lzh741206发表于2009-5-21 13:09:00把你的代码贴上看看吧，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

雪山飞狐_lzh

试下吧

2.    
3. '打开到一张图纸上
4. Public Sub CopyFromOuterDwg(CurDocname As String, NewDocname As String)
5.     ' 打开第一张图
6.     Dim objCurDoc As AcadDocument
7.     Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery" & CurDocname & ".dwg")
8.     ' 打开一个新图形
9.     Dim objNewDoc As AcadDocument
10.     Set objNewDoc = acadapp.Application.Documents(App.Path & "\Gallery" & NewDocname & ".dwg")
11.    
12.     ' 将外部图形的实体复制到当前图形
13.     Set ssetobj = CreateSelectionSet(objNewDoc, "test")
14.     ssetobj.Select acSelectionSetAll
15.     objNewDoc.CopyObjects ssArray(ssetobj), objCurDoc.ModelSpace
16.     objCurDoc.Regen acAllViewports
17.     ' 关闭打开的图形
18.     objNewDoc.Close (False)
19. End Sub
20. '返回包含于选择集中每一项目的变体数,参数:一选择集
21. Public Function ssArray(ss As AcadSelectionSet)
22.     Dim retVal() As AcadEntity, k As Long
23.     ReDim retVal(0 To ss.Count - 1)
24.     For k = 0 To ss.Count - 1
25.         Set retVal(k) = ss.Item(k)
26.     Next
27.     ssArray = retVal
28. End Function
29. '建立选择集
30. Public Function CreateSelectionSet(ByVal Doc As AcadDocument, ByVal SSetName As String) As AcadSelectionSet
31.     On Error Resume Next
32.     Doc.SelectionSets(SSetName).Delete
33.     Set CreateSelectionSet = Doc.SelectionSets.Add(SSetName)
34. 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