Auto CAD vba 怎样创建匿名块

cad中创建匿名组容易，但确不能创建匿名块，因为cad不可直接编辑匿名块。我有的时候希望直接创建匿名块。

'创建匿名块
Sub NiMingBlock()
    On Error Resume Next
    If Err Then End
    Dim FilterSet As AcadSelectionSet
    Dim Blk As AcadBlock
    Dim E As AcadEntity
    Dim P As Variant
    Dim i As Integer
    Dim obj() As Object

    Set FilterSet = ThisDrawing.SelectionSets.Add("XXX")
    If Err Then
        ThisDrawing.SelectionSets("XXX").Delete
        Set FilterSet = ThisDrawing.SelectionSets.Add("XXX")
        Err.Clear
    End If

    FilterSet.SelectOnScreen

    '将选择集中对象传递给Obj对象数组
    ReDim obj(0 To FilterSet.Count - 1) As Object
    For i = 0 To FilterSet.Count - 1
        Set obj(i) = FilterSet.item(i)
    Next i

    Dim Pmin As Variant, Pmax As Variant
    FilterSet.item(0).GetBoundingBox Pmin, Pmax
    '匿名块的插入点为第一个对象的角点
    Set Blk = ThisDrawing.Blocks.Add(Pmin, "*B")

    ThisDrawing.CopyObjects obj, Blk

    For Each E In FilterSet
        E.Delete
    Next

    ThisDrawing.ModelSpace.InsertBlock Point3D(0, 0, 0), Blk.Name, 1, 1, 1, 0

    '删除选择集
    ThisDrawing.SelectionSets.item("XXX").Delete
End Sub

[本日志由 tiancao1001 于 2008-09-18 03:21 PM 编辑]

分享到： QQ空间新浪微博腾讯微博微信更多

dfgd 于 2009-01-10 03:30 PM 发表评论：

无痛人流好不好？我想去妇科医院做人流

手术，不知道先前要做哪些妇科检查，若是有 妇科病会怎么样？

妇科炎症难不难治，上网妇科咨询了下，说要先做个妇科常规检查，看有没有得

阴道炎，尿道炎，特别是宫颈

糜烂。小心这些妇科疾病造成的后遗症，常见会有白带异常，

月经不调等症状.

tiancao1001 于 2008-09-18 03:20 PM 发表评论：

这个程序我又改了，因为以前的图图之间出现很多同名块，不方便图与图中的拷贝

'创建匿名块
Sub NiMingBlock1()
    On Error Resume Next
    If Err Then End
    Dim FilterSet As AcadSelectionSet
    Dim Blk As AcadBlock
    Dim E As AcadEntity
    Dim P As Variant
    Dim i As Integer
    Dim Obj() As Object

    Set FilterSet = ThisDrawing.SelectionSets.Add("XXX")
    If Err Then
        ThisDrawing.SelectionSets("XXX").Delete
        Set FilterSet = ThisDrawing.SelectionSets.Add("XXX")
        Err.Clear
    End If

    FilterSet.SelectOnScreen

    '将选择集中对象传递给Obj对象数组
    ReDim Obj(0 To FilterSet.Count - 1) As Object
    For i = 0 To FilterSet.Count - 1
        Set Obj(i) = FilterSet.item(i)
    Next i

    Dim Pmin As Variant, Pmax As Variant
    FilterSet.item(0).GetBoundingBox Pmin, Pmax

    Dim B_Name As String
    B_Name = NiMingKuai2("TC")
    Dim Temp As String
    '以文档创建时间后缀命名,(你可能同一时间创建两个块吗?,这样避免同名块,图和图之间不好复制)
    Temp = CStr(ThisDrawing.GetVariable("DATE"))
    B_Name = B_Name & "." & Temp
    '匿名块的插入点为第一个对象的角点
    Set Blk = ThisDrawing.Blocks.Add(Pmin, B_Name)

    ThisDrawing.CopyObjects Obj, Blk

    For Each E In FilterSet
        E.Delete
    Next

    ThisDrawing.ModelSpace.InsertBlock Pmin, Blk.Name, 1, 1, 1, 0

    '删除选择集
    ThisDrawing.SelectionSets.item("XXX").Delete
End Sub

'创建匿名块
Function NiMingKuai2(S As String) As String
    Dim blockObj As AcadBlock
    Dim N As Long
    NiMingKuai2 = S & "000"
Block:
    For Each blockObj In ThisDrawing.Blocks
        If Left(blockObj.Name, 5) = NiMingKuai2 Then '这里取5,是S的长度+3
            NiMingKuai2 = S & Format(N, "000")
            Prompt NiMingKuai2
            N = N + 1
            GoTo Block
        End If
    Next blockObj
End Function

田草于 2008-07-15 08:54 AM 发表评论：

'创建匿名块
Function NiMingKuai(S As String) As String
    Dim blockObj As AcadBlock
    Dim n As Long
    NiMingKuai = S & "_0"
Block:
    For Each blockObj In ThisDrawing.Blocks
        If blockObj.Name = NiMingKuai Then
            NiMingKuai = S & "_" & CStr(n)
            Prompt NiMingKuai
            n = n + 1
            GoTo Block
        End If
    Next blockObj
End Function

田草于 2008-07-12 09:23 AM 发表评论：

'创建匿名块，没有则创建，有则序号加一
Function NiMingKuai(S As String) As String
    Dim B As AcadBlock
    Dim n As Long
    Dim m As Long
    For Each B In ThisDrawing.Blocks
        If Left(B.Name, Len(S)) = S Then
            m = Val(Mid(B.Name, Len(S) + 1))
            If n <= m Then n = m + 1
        End If
    Next
    NiMingKuai = S & n
End Function

发表评论 - 不要忘了输入验证码哦！

作者：

用户：密码：注册？验证：