实体加入到块中，怎么用CopyObjects 的方法copy不到块去

qsl707

Sub block()
Dim Po() As Double
Dim ss As AcadSelectionSet
Dim Bk As AcadBlock

On Error Resume Next

Po(0) = 0
Po(1) = 0
Po(2) = 0

'ThisDrawing.Blocks.Item("ok").Delete

Set Bk = ThisDrawing.Blocks.Add(Po, "tempb")

Set ss = ThisDrawing.SelectionSets.Item("ssss")
'------------------------------------------------
If Err Then
Err.Clear
Set ss = ThisDrawing.SelectionSets.Add("ssss")
End If
'------------------------------------------------
ss.Select acSelectionSetAll
'------------------------------------------------过滤对象
Dim retVal() As AcadEntity
Dim Ent As AcadEntity

Dim i As Integer
i = 0

    ReDim retVal(0 To ss.Count - 1)
   
    For Each Ent In ss
       
        If (Ent.Layer = "layer") Then
            Set retVal(i) = Ent
            Ent.Delete
            i = i + 1
        End If
       
    Next
    ReDim Preserve retVal(0 To i - 1)

'------------------------------------------------
MsgBox "shiti" & ss.Count
ThisDrawing.CopyObjects retVal(), Bk  '  在这里出问题了
MsgBox "bk" & Bk.Count
ThisDrawing.ModelSpace.InsertBlock Po, "tempb", 1, 1, 1, 90
ss.Delete
MsgBox "end"
End Sub

qsl707

版主快回答我呀，我急死了

霹雳啪啦啦

    For Each Ent In ss
       
        If (Ent.Layer = "layer") Then
            Set retVal(i) = Ent
            Ent.Delete
            i = i + 1
        End If
       
    Next
Ent.Delete有问题。你都把Ent给删除了，怎么拷贝到块里去？

雪山飞狐_lzh

2. Sub tt()
3. On Error Resume Next
4.     Dim objs() As AcadEntity
5.     Dim ss As AcadSelectionSet
6.     ThisDrawing.SelectionSets("Test").Delete
7.     Set ss = ThisDrawing.SelectionSets.Add("Test")
8.    
9.     Dim ft(0) As Integer, fd(0)
10.     ft(0) = 8: fd(0) = "layer"
11.     ss.Select acSelectionSetAll, , , ft, fd
12.    
13.     ReDim objs(ss.Count - 1)
14.     Dim i
15.     For i = 0 To ss.Count - 1
16.         Set objs(i) = ss(i)
17.     Next i
18.    
19.     Dim blk As AcadBlock
20.     Dim pnt(2) As Double
21.     Set blk = ThisDrawing.Blocks.Add(pnt, "tempb")
22.    
23.     ThisDrawing.CopyObjects objs, blk
24. End Sub

Sub tt() On Error Resume Next     Dim objs() As AcadEntity     Dim ss As AcadSelectionSet     ThisDrawing.SelectionSets("Test").Delete     Set ss = ThisDrawing.SelectionSets.Add("Test")         Dim ft(0) As Integer, fd(0)     ft(0) = 8: fd(0) = "layer"     ss.Select acSelectionSetAll, , , ft, fd         ReDim objs(ss.Count - 1)     Dim i     For i = 0 To ss.Count - 1         Set objs(i) = ss(i)     Next i         Dim blk As AcadBlock     Dim pnt(2) As Double     Set blk = ThisDrawing.Blocks.Add(pnt, "tempb")         ThisDrawing.CopyObjects objs, blk End Sub

alin

Please make sure all objects to be copied are in the same space, ie, modelspace
Otherwise the CopyObjects method will fail.

qsl707

lzh741206老大，非常感谢，我照你的方法成功了，但我一直搞不懂我的程序错在那儿了，恳请指点！也希望能得到其他高手出招支持，但决不是霹雳啪啦啦说的ent.delete的问题

我现在想做个程序，就是在程序中创建若干个实体，比如建一个圆，然后创建个矩形，再画一条多义线（上述三项不在同一层），然后加入这三个到同一个块中．在modespace中插入这个块，并删除刚刚建的圆＼矩形＼多义线，只保留这个块．希望lzh741206版主给我帮助，谢谢了

 

 

qsl707

alin发表于2006-8-3 12:44:00Please make sure all objects to be copied are in the same space, ie, modelspaceOtherwise the CopyObjects method will fail.

Dear alin,thank you!Ｉam sure all my objects are copied in the same space(modelspace),why failure always keep up with me.

alin

Sub block()
Dim Po(2) As Double
Dim ss As AcadSelectionSet
Dim Bk As AcadBlock

On Error Resume Next

Po(0) = 0
Po(1) = 0
Po(2) = 0

'ThisDrawing.Blocks.Item("ok").Delete

Set Bk = ThisDrawing.Blocks.Add(Po, "tempb")

Set ss = ThisDrawing.SelectionSets.Item("ssss")
'------------------------------------------------
If Err Then
Err.Clear
Set ss = ThisDrawing.SelectionSets.Add("ssss")
End If
'------------------------------------------------
ss.Select acSelectionSetAll
'------------------------------------------------????
Dim retVal() As AcadEntity
Dim Ent As AcadEntity

Dim i As Integer
i = 0

    ReDim retVal(ss.Count - 1)
   
    For Each Ent In ss
       
        If (Ent.Layer = "Layer") Then
            Set retVal(i) = Ent
'            Ent.Delete
            i = i + 1
        End If
       
    Next
    ReDim Preserve retVal(i - 1)

'------------------------------------------------
MsgBox "shiti" & ss.Count
ThisDrawing.CopyObjects retVal, Bk  '  ???????
MsgBox "bk" & Bk.Count
'ThisDrawing.ModelSpace.InsertBlock Po, "tempb", 1, 1, 1, 90
ss.Delete
MsgBox "end"
End Sub

 

qsl707

alin版大 ,仍然失败!

alin

怎样的“失败”？你的图中有在图层Layer上的图元吗？最好你把你的图贴上来。