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

zdm860114

好的，我试试，谢谢斑竹！！

zdm860114

这个方法还是不行啊，不过给了些思路

我换了个思路做，只是麻烦多了

是用open的方法打开，代码多了不少。。。

很谢谢版主来热心帮助，真的很感谢！

还有个问题，希望版主能再帮我一次，占用你大量的时间，真的很感激！

选择集如何移动呢？从一个指定点到另一个指定点

mccad

你把VB与AutoCAD连接的代码贴出来看看。

zdm860114

mccad发表于2009-5-21 20:01:00你把VB与AutoCAD连接的代码贴出来看看。

Option Explicit
Public acadapp As AcadApplication
Public AcadDocs As AcadDocuments
Public MoSpace As AcadModelSpace
Public AcadDoc As AcadDocument
Public MainForm As VB.Form

Public i As Integer

'连接AutoCAD子函数
Public Sub AutoCAD_Appliaction()
    On Error Resume Next
    Dim Thisdrawing As AcadDocument
    Set acadapp = GetObject(, "AutoCAD.Application.16")
    If Err Then
        Err.Clear
        Set acadapp = CreateObject("AutoCAD.Application.16")
        If Err Then
            MainForm.Visible = False
            MsgBox Err.Description
            MainForm.Visible = True
            Exit Sub
        End If
    Else
        If acadapp.Documents.Count >= 1 Then
            For i = acadapp.Documents.Count To 1 Step -1
                Set Thisdrawing = acadapp.Documents.Item(i - 1)
                If Not acadapp.ActiveDocument.Saved Then
                   If MsgBox("是否要保存以前打开的.dwg文件？", vbYesNo) = vbYes Then
                      acadapp.ActiveDocument.Save
                   Else
                   acadapp.ActiveDocument.Close (False)
                   End If
                End If
                Thisdrawing.Close
            Next
        End If
    End If
    Set Thisdrawing = Nothing
    acadapp.Visible = True
    acadapp.WindowState = acMax
End Sub

请指教！谢谢了！

mccad

看了你的代码，还不太好说：

1.acadapp本身是AcadApplication对象，就不能用acadapp.Application，而需要直接acadapp.Documents("文件名")。

2. 新图形 Dim objNewDoc As AcadDocument 下面的那句语句，应该是Set objNewDoc ...。

3.你写的VB与AutoCAD连接的代码，判断如果ACAD是打开的话，则关闭所有已经打开的文档，我不知道这点有没有影响，因为没看到你中间的其它代码，是不是自己手动打开你需要的文档还是其它。

4.你的图库是否就是VB程序所在目录的Gallery子目录中，如果不是则文件会找不到。

zdm860114

mccad发表于2009-5-22 21:07:00看了你的代码，还不太好说：1.acadapp本身是AcadApplication对象，就不能用acadapp.Application，而需要直接acadapp.Documents(\"文件名\")。2. 新图形 Dim objNewDoc As AcadDocument 下面的那

恩，先谢谢了！

1.这个我也试过。呵呵，不过好像还是不行，不过给我指出了到底该怎么写这句话了。

2.恩，这个我后来是修改的时候发现了这个错误，眼力真好！

3.这点主要是为了判断在运行程序前是否有ACAD打开了，以免受影响，可能是想过了头，可以不要这句的

4.图库就是建立在VB程序所在目录中的Gallery子目录中，所以我用了APP.PATH

最后真的很感谢mccad和lzh741206！还是要感谢这个论坛给我学习二次开发提供了很多帮助

很多问题先是经过搜索论坛和百度解决了，是在没有解决的，最终都在版主们和大家的热心帮助下基本上都解决了

谢谢了！

zdm860114

目前就只缺那个没有实现，还是会提示错误。如果实现了就好。

全部代码如下：

'连接AutoCAD
Public Sub AutoCAD_Appliaction()
    On Error Resume Next
    Dim Thisdrawing As AcadDocument
    Set acadapp = GetObject(, "AutoCAD.Application.16")
    If Err Then
        Err.Clear
        Set acadapp = CreateObject("AutoCAD.Application.16")
        If Err Then
            MainForm.Visible = False
            MsgBox Err.Description
            MainForm.Visible = True
            Exit Sub
        End If
    Else
        If acadapp.Documents.Count >= 1 Then
            For i = acadapp.Documents.Count To 1 Step -1
                Set Thisdrawing = acadapp.Documents.Item(i - 1)
                If Not acadapp.ActiveDocument.Saved Then
                   If MsgBox("是否要保存以前打开的.dwg文件？", vbYesNo) = vbYes Then
                      acadapp.ActiveDocument.Save
                   Else
                   acadapp.ActiveDocument.Close (False)
                   End If
                End If
                Thisdrawing.Close
            Next
        End If
    End If
    Set Thisdrawing = Nothing
    acadapp.Visible = True
    acadapp.WindowState = acMax
End Sub

'打开图库
Public Sub Open_Gallery(Galleryname As String)
On Error Resume Next
Dim file As String
file = App.Path & "\Gallery\" & Galleryname & ".dwg"
    If Dir(file) <> "" Then
       acadapp.Documents.Open file
    Else
       MsgBox ("文件" & Galleryname & "不存在")
    End If
End Sub

'建立选择集并遍历选择集中实体并复制移动实体
Public Sub copy_moveSset(selectname As String, jielength As Double, jienum As Integer, Layername As String)
On Error Resume Next
    acadapp.SelectionSets(selectname).Delete
    Set ssetobj = acadapp.ActiveDocument.SelectionSets.Add(selectname)
AppActivate acadapp.Caption
'建立选择集，选择图层
Dim fType(0) As Integer
Dim fData(0) As Variant
    fType(0) = 8
    fData(0) = Layername
Dim FilterType As Variant
Dim FilterData As Variant
    FilterType = fType
    FilterData = fData
ssetobj.Select acSelectionSetAll, , , fType, fData
Dim entry As AcadEntity
Dim coent As Variant
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
    For i = 1 To jienum
    point1(0) = 0#
    point1(1) = 0#
    point1(2) = 0#
    point2(0) = point1(0) + (i - 1) * jielength
    point2(1) = 0#
    point2(2) = 0#
        For Each entry In ssetobj
            Set coent = entry.Copy
            Call coent.Move(point1, point2)
        Next
    Next i
 ssetobj.Delete
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(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.Documents(App.Path & "\Gallery\" & CurDocname & ".dwg")
' 打开一个新图形
     Dim objNewDoc As AcadDocument
     Set objNewDoc = acadapp.Documents(App.Path & "\Gallery\" & NewDocname & ".dwg")
     Set objNewDoc = acadapp.ActiveDocument
' 将外部图形的实体复制到当前图形
     Set ssetobj = CreateSelectionSet
     ssetobj.Select acSelectionSetAll
     acadapp.ActiveDocument.CopyObjects ssArray(ssetobj), objCurDoc.ModelSpace
     objCurDoc.Regen acAllViewports
 ' 关闭打开的图形
     objNewDoc.Close (False)
End Sub

Private Sub Command7_Click()

     AutoCAD_Appliaction
    Open_Gallery "预热带前段"
    copy_moveSset "NEW1", 232, Val(copy_move.yc_1.Text), "0"
    Open_Gallery "预热带中段"
    copy_moveSset "NEW1", 232, Val(copy_move.yc_2.Text), "0"
    Open_Gallery "预热带后段"
    copy_moveSset "NEW1", 232, Val(copy_move.yc_3.Text), "0"
      CopyFromOuter "预热带前段", "预热带中段"
   CopyFromOuter "预热带前段", "预热带后段"
End Sub

mccad

整个程序看过了，因为没有VB，就没有做调试，第一感觉这句有问题：
CopyFromOuter "预热带前段", "预热带后段"
前面已经有调用过一次CopyFromOuter ，此时"预热带后段"已经被关了，第二次调用肯定就会出错。

你是通过程序打开图库文件，最好的方法是直接把打开的文件用变量保存起来，下次调用时就直接用该变量来调用，而不要再通过文件名来指定文件，这样对于编程来说会有好处。