田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



真正的建筑CAD字体大全 归并图层和字体样式
未知 Auto CAD vba 怎样 创建匿名块   [ 日期:2007-11-21 ]   [ 来自:本站原创 ]  HTML
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 编辑]


引用这个评论 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

发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*3=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©