田草博客

互联网田草博客


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

微信 公众号:ByCAD

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

用户登陆
用户:
密码:
 

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


站点统计

最新评论



生成图纸目录 局域网设置,关键五点
未知 vba写像天正建筑一样的连续标注   [ 日期:2007-11-08 ]   [ 来自:本站原创 ]  HTML
vba写像天正建筑一样的连续标注



按此在新窗口打开图片
'连续标注
Sub LXBZ()
    Dim P()  As Variant '标注点集
    Dim temp As Variant '标注位置
    Dim i As Integer, j As Integer, L As Long
    Dim E() As AcadEntity '标注对象集
    
    Dim LXBZGroup As AcadGroup
    Dim NiMing As String
    NiMing = NiMingZu("LXBZ")
    Set LXBZGroup = ThisDrawing.Groups.Add(NiMing)
    On Error GoTo E:
    ReDim Preserve P(1)
    ReDim Preserve E(0)
    '创建第一个标注,后面的标注均以这个标注为基准。
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(0) = ThisDrawing.Utility.GetPoint(, "指定点:>")
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(1) = ThisDrawing.Utility.GetPoint(P(0), "下一点:>")
    Set E(0) = ThisDrawing.ModelSpace.AddDimAligned(P(j), P(j + 1), CenterPoint(P(0), P(1)))
    '标注尺寸线位置:
    ThisDrawing.Utility.InitializeUserInput 1, ""
    temp = ThisDrawing.Utility.GetPoint(CenterPoint(P(0), P(1)), "标注尺寸线位置:>")
    '删除一个尺寸标注,按照新的位置重新标注。
    E(0).Delete
    Set E(0) = ThisDrawing.ModelSpace.AddDimAligned(P(0), P(1), temp)
    i = 1
N:
    '标注下一点
    i = i + 1
    ReDim Preserve P(i)
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(i) = ThisDrawing.Utility.GetPoint(P(i - 1), "下一点")
    '为了使标注在一条直线上,所以要求新的点到直线的垂足点坐标。
    P(i) = ChuiZuP2L(P(i - 2), P(i - 1), P(i))
    '如果这个点在前面的所有点中间,就要分割他相邻两点之间的一个标注。这里的处理方法删除了前面标注重新再标注。
    For L = 0 To UBound(E)
        E(L).Delete
    Next
    '重新定义数值
    ReDim E(i - 1)
    '对点坐标进行排序
    DianPaiXu1 P
    '绘制新的连续标注
    For j = 0 To i - 1
        Set E(j) = ThisDrawing.ModelSpace.AddDimAligned(P(j), P(j + 1), temp)
    Next
    GoTo N:
E:
    LXBZGroup.AppendItems E
    Prompt Err.Description
End Sub


'增补标注
Sub ZBBZ()
    Dim P()  As Variant '标注点集
    Dim E() As AcadEntity '标注对象集
    Dim TP As Variant
    Dim DStyle As String
    Dim DLayer As String
    Dim i As Integer, j As Integer
    
    ReDim Preserve P(1)
    ReDim Preserve E(0)
    
    Dim LXBZGroup As AcadGroup
    Dim NiMing As String
    NiMing = NiMingZu("LXBZ")
    Set LXBZGroup = ThisDrawing.Groups.Add(NiMing)

    Dim D1 As AcadDimAligned
    Dim D2 As AcadDimRotated
    Dim temp As AcadEntity
    Dim PickedPoint As Variant
    On Error GoTo E:
N:
    '先选择一个标注对象
    ThisDrawing.Utility.GetEntity temp, PickedPoint, "请选择一个标注对像"
    If temp.ObjectName = "AcDbRotatedDimension" Then
        GoTo N:
    ElseIf temp.ObjectName = "AcDbAlignedDimension" Then
       '获得该对齐对象的特性,
       Set D1 = temp
       P(0) = D1.ExtLine1Point
       P(1) = D1.ExtLine2Point
       TP = D1.TextPosition
       DStyle = D1.StyleName
       DLayer = D1.Layer
       D1.Delete
       Set E(0) = ThisDrawing.ModelSpace.AddDimAligned(P(0), P(1), TP)
       'Set E(0) = temp
    Else
        GoTo N:
    End If
    i = 1
M:
    '标注下一点
    i = i + 1
    ReDim Preserve P(i)
    ThisDrawing.Utility.InitializeUserInput 1, ""
    P(i) = ThisDrawing.Utility.GetPoint(P(i - 1), "下一点")
    '为了使标注在一条直线上,所以要求新的点到直线的垂足点坐标。
    P(i) = ChuiZuP2L(P(i - 2), P(i - 1), P(i))
    '如果这个点在前面的所有点中间,就要分割他相邻两点之间的一个标注。这里的处理方法删除了前面标注重新再标注。
    For j = 0 To UBound(E)
        E(j).Delete
    Next
    '重新定义数值
    ReDim E(i - 1)
    '对点坐标进行排序
    DianPaiXu1 P
    '绘制新的连续标注
    For j = 0 To i - 1
        Set E(j) = ThisDrawing.ModelSpace.AddDimAligned(P(j), P(j + 1), TP)
        E(j).StyleName = DStyle
        E(j).Layer = DLayer
    Next
    GoTo M:
E:
    If UBound(E) <> 0 Then LXBZGroup.AppendItems E
    Prompt Err.Description
End Sub



[本日志由 田草 于 2007-12-22 01:10 PM 编辑]


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

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

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