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

zdm860114 发表于 2009-5-20 18:21:00

本帖最后由作者于 2009-5-21 10:20:00 编辑 如题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 发表于 2009-5-20 18:40:00

如果是新建的可以试下Acadapp.Application.Documents(Acadapp.Application.Documents.Count - 1)

zdm860114 发表于 2009-5-20 23:09:00

本帖最后由作者于 2009-5-21 9:47:29 编辑 不是新建的，我是打开图库中的图所以不知道该怎么解决VBA中就能用，在VB中咋就不能用了呢我的想法是这样的先打开图库中的3个图，分别操作后，放到一张图上，也就是放到一个文档上就是在这句时不能实现Set objCurDoc = acadapp.Application.Documents(App.Path & "\Gallery\" & NewDocname & ".dwg")VBA中是这样的一句：Set doc = Thisdrawing.Application.Documents("Drawing1.dwg") 请高手帮忙，谢谢了！

sailorcwx 发表于 2009-5-21 01:37:00

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

zdm860114 发表于 2009-5-21 09:59:00

首先谢谢楼上两位的热心解答不过我试过Set doc = Acadapp.Documents("Drawing1.dwg")这句还是会提示那样的错误真不知道怎么解决，请大家用你们的智慧帮我解答下，不甚感激！

雪山飞狐_lzh 发表于 2009-5-21 12:31:00

当前文档先保存在一个变量里然后用三个doc变量保存你打开的文档

zdm860114 发表于 2009-5-21 12:55:00

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

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

雪山飞狐_lzh 发表于 2009-5-21 13:09:00

把你的代码贴上看看吧，VBA没有装了，：）或者你可以试下ObjectDBX？

zdm860114 发表于 2009-5-21 16:00:00

lzh741206发表于2009-5-21 13:09:00static/image/common/back.gif把你的代码贴上看看吧，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 发表于 2009-5-21 16:38:00

试下吧

'打开到一张图纸上
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] 2

明经CAD社区's Archiver

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