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

qsl707 发表于 2006-8-2 13:31:00

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 发表于 2006-8-2 14:40:00

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

霹雳啪啦啦 发表于 2006-8-2 16:47:00

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 发表于 2006-8-2 21:32:00

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 发表于 2006-8-3 12:44:00

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

qsl707 发表于 2006-8-3 23:15:00

<A name=26396>lzh741206</A>老大，非常感谢，我照你的方法成功了，但我一直搞不懂我的程序错在那儿了，恳请指点！也希望能得到其他高手出招支持，但决不是<A name=26357>霹雳啪啦啦</A>说的ent.delete的问题
我现在想做个程序，就是在程序中创建若干个实体，比如建一个圆，然后创建个矩形，再画一条多义线（上述三项不在同一层），然后加入这三个到同一个块中．在modespace中插入这个块，并删除刚刚建的圆＼矩形＼多义线，只保留这个块．希望<A name=26396>lzh741206</A>版主给我帮助，谢谢了

qsl707 发表于 2006-8-3 23:20:00

alin发表于2006-8-3 12:44:00static/image/common/back.gifPlease 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 发表于 2006-8-4 08:40:00

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 发表于 2006-8-4 11:07:00

alin版大 ,仍然失败!

alin 发表于 2006-8-4 16:11:00

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

页: [1] 2

明经CAD社区's Archiver

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