实体加入到块中，怎么用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

copy


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

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

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

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上的图元吗？最好你把你的图贴上来。

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

发表回复

精选推荐