[求助]：块替换

myfreemind

最初由 snow-rose 发布
[B]在平面图中插入一个块30次，但现在要修改其中的15处用另一个块替代，能否象WORD一样自动查找并提示是否替换。 [/B]

试一下这个程序：
Dim tkobj As AcadBlockReference
Dim pnt As Variant
Dim entity As AcadEntity
Dim i As Integer
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
Dim tkset As AcadSelectionSet
Dim Ftype(0) As Integer
Dim Fdata(0) As Variant
Ftype(0) = 2
Fdata(0) = "GC211"
Set tkset = ThisDrawing.SelectionSets.Add("tksset")
tkset.Select acSelectionSetAll, , , Ftype, Fdata

For Each entity In tkset
'For Each entity In ThisDrawing.ModelSpace
pnt = entity.InsertionPoint
entity.Delete
Set tkobj = ThisDrawing.ModelSpace.InsertBlock(pnt, "gc209.dwg", 1, 1, 1, 0)

Next



End Sub

iam0411

再这里，我也学到了好多知识，谢谢你*-*1

timnis

不错,谢谢,正好要用此功能!

taobqr

这个问题有点难，我也正在研究。

liyer

我用了，就是用那么一点要改进的地方

colatree

我有一個不知適不適用
1.選擇block圖元，判別區塊名
2.ssget選擇block圖元，可分辨是否是block
3.輸入替代的新block name
完成
歡迎各位不吝賜教

burning

对，做一个格式刷的程序最好，就不用麻烦没次都要重复一件事！
有好心人出来，绝对支持！

liuyan629

小妹我不懂，它的快捷健命令是多少？

MYSKY1234563314

要怎么使呢绒

yuancuang

不太好用，有没有更好的。

雪山飞狐(lzh)

试试这个
VBA代码
[Code]
Sub TlsBlockReplace()
    Dim ss As AcadSelectionSet
    Dim ft(0) As Integer, fd(0)
    Dim pName As String
    Dim i As AcadBlockReference
   
    Set ss = ThisDrawing.ActiveSelectionSet
   
    If ss(0).ObjectName = "AcDbBlockReference" Then
        pName = ss(0).Name
        ss.Clear
        ft(0) = 0: fd(0) = "Insert"
        ss.SelectOnScreen ft, fd
        For Each i In ss
        ThisDrawing.ModelSpace.InsertBlock( _
                        i.InsertionPoint, _
                        pName, _
                        i.XScaleFactor, _
                        i.YScaleFactor, _
                        i.ZScaleFactor, _
                        i.Rotation) _
                        .Layer = i.Layer
        i.Delete
        Next i
    End If
   
    ss.Delete
End Sub
[/Code]
Lisp代码
[Code]
(defun c:TlsBR()
(setvar "cmdecho" 0)
(if (ssget) (command "-vbarun" "TlsBlockReplace"))
(setvar "cmdecho" 1)
(princ)
)
[/Code]

陌生人

最初由 lzh741206 发布
[B]试试这个
VBA代码
[Code]
Sub TlsBlockReplace()
    Dim ss As AcadSelectionSet
    Dim ft(0) As Integer, fd(0)
    Dim pName As String
    Dim i As AcadBlockReference
   
    Set ss = ThisDraw... [/B]

直接插块，对有属性的行么？

雪山飞狐(lzh)

没有考虑属性，：（
你的演示里替换块时保留了多余的属性，有必要麽？

陌生人

有必要的，不过也可分两种情况，一种考虑带属性，一种如你的程序
带属性，正如演示，当做门窗选型替换时候，保留的属性是门编号，丢了就只好自己写上了：）

雪山飞狐(lzh)

这个呢？
VBA代码
[Code]
Sub TlsBlockReplace()
    Dim ss As AcadSelectionSet
    Dim ft(0) As Integer, fd(0)
    Dim pName As String
    Dim i
    Dim pBlock As AcadBlock
    Dim pnt(2) As Double
    Set ss = ThisDrawing.ActiveSelectionSet
    Dim pObj As AcadBlockReference
    Dim pAttribs(1)
    If ss(0).ObjectName = "AcDbBlockReference" Then
   
        pName = ss(0).Name
        
        Set pBlock = ThisDrawing.Blocks.Add(pnt, "*U")
        
        CopyAttributes ThisDrawing.Blocks(pName), pBlock
        
        ft(0) = 0: fd(0) = "Insert"
        ss.Clear
        ss.SelectOnScreen ft, fd
        For Each i In ss
        
        CopyAttributes ThisDrawing.Blocks(i.Name), ThisDrawing.Blocks(pName), False
            
            Set pObj = ThisDrawing.ModelSpace.InsertBlock( _
                                i.InsertionPoint, _
                                pName, _
                                i.XScaleFactor, _
                                i.YScaleFactor, _
                                i.ZScaleFactor, _
                                i.Rotation)
            pObj.Layer = i.Layer
            pAttribs(0) = i.GetAttributes: pAttribs(1) = pObj.GetAttributes
            For j = 0 To UBound(pAttribs(0))
                pAttribs(1)(j).TextString = pAttribs(0)(j).TextString
            Next j
            
        DeleteAttributes ThisDrawing.Blocks(pName)
        i.Delete
        
        Next i
    End If
    CopyAttributes pBlock, ThisDrawing.Blocks(pName)
    pBlock.Delete
End Sub

Public Sub CopyAttributes(ByRef sBlock As AcadBlock, ByRef dBlock As AcadBlock, Optional ByRef Delete As Boolean = True)
    Dim pObjs(0) As AcadEntity
   
    Dim i
    For Each i In sBlock
        If i.ObjectName = "AcDbAttributeDefinition" Then
            Set pObjs(0) = i
            ThisDrawing.CopyObjects pObjs, dBlock
        End If
    Next i

    If Delete Then
        DeleteAttributes sBlock
    End If

End Sub

Public Sub DeleteAttributes(ByRef Block As AcadBlock)
    Dim i
   
    For Each i In Block
   
        If i.ObjectName = "AcDbAttributeDefinition" Then
        
            i.Delete
        
        End If
        
    Next i

End Sub
[/Code]
Lisp代码
[Code]
(defun c:TlsBR()
(setvar "cmdecho" 0)
(if (ssget) (command "-vbarun" "TlsBlockReplace"))
(setvar "cmdecho" 1)
(princ)
)
[/Code]
还有点bug，：）