田草博客

互联网田草博客


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

微信 公众号:ByCAD

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

用户登陆
用户:
密码:
 

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


站点统计

最新评论



返回混凝土各种系数 2007年大盘点
未知 平面索引、剖面索引、多行引注   [ 日期:2007-12-22 ]   [ 来自:本站原创 ]  HTML
'创建平面索引
Sub PingMianSY()
   
    Dim p1 As Variant
    p1 = ThisDrawing.Utility.GetPoint(, "索引区域中心点:")
    Dim p2 As Variant
    p2 = ThisDrawing.Utility.GetPoint(p1, "索引区域边界点:")
    '绘制索引区域的一个圆
    Dim Circle1 As AcadCircle
    Set Circle1 = ThisDrawing.ModelSpace.AddCircle(p1, P2PDistance(p1, p2))
     
    Dim P3 As Variant
    Dim P4 As Variant
    Dim L1 As AcadLine
    Dim L2 As AcadLine
    P3 = ThisDrawing.Utility.GetPoint(p2, "索引第一点:")
    Set L1 = ThisDrawing.ModelSpace.AddLine(p2, P3)
    P4 = ThisDrawing.Utility.GetPoint(P3, "索引第二点:")
    Set L2 = ThisDrawing.ModelSpace.AddLine(P3, P4)
    
    Dim B As AcadBlock
    Set B = ThisDrawing.Blocks.Add(Point3D(0, 0, 0), "*J")
    
    Dim a As Double
    a = L2.angle
    Dim C As Variant
    Dim P5 As Variant
    Dim P6 As Variant
    P6 = Point3D(0, 0, 0)
    C = GetPointAR(P6, a, 500)
    P5 = GetPointAR(P6, a, 1000)
    Dim Circle2 As AcadCircle
    Set Circle2 = B.AddCircle(C, 500)
    Dim L3 As AcadLine
    Set L3 = B.AddLine(P6, P5)
     
    Dim H As Integer
    Dim Pi As Double
    
    Pi = Atn(1) * 4
    
    If a > Pi / 2 And a < 3 * Pi / 2 Then
        H = -100
    Else
        H = 100
    End If
    
    Dim Att As AcadAttribute
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "索引说明(上)", "节点详见图集")
    Att.Alignment = acAlignmentBottomRight
    Att.Move Att.TextAlignmentPoint, Point3D(P6(0), P6(1) + H, P6(2))
    Att.Rotate Att.TextAlignmentPoint, a
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "索引说明(下)", "苏J01-2003")
    Att.Alignment = acAlignmentTopRight
    Att.Move Att.TextAlignmentPoint, Point3D(P6(0), P6(1) - H, P6(2))
    Att.Rotate Att.TextAlignmentPoint, a
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "序号", "1")
    Att.Alignment = acAlignmentBottomCenter
    Att.Move Att.TextAlignmentPoint, Point3D(C(0), C(1) + H, C(2))
    Att.Rotate Att.TextAlignmentPoint, a
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "第几页", "10")
    Att.Alignment = acAlignmentTopCenter
    Att.Move Att.TextAlignmentPoint, Point3D(C(0), C(1) - H, C(2))
    Att.Rotate Att.TextAlignmentPoint, a
    
    Dim Bref As AcadBlockReference
    Set Bref = ThisDrawing.ModelSpace.InsertBlock(P4, B.Name, 1, 1, 1, 0)
    
    Dim G As AcadGroup
    Dim ObjList(3) As AcadEntity
    Dim NiMing As String
    NiMing = NiMingZu("平面索引")
 
    Dim PMSY As AcadGroup
    Set PMSY = ThisDrawing.Groups.Add(NiMing)
    Set ObjList(0) = Circle1
    Set ObjList(1) = L1
    Set ObjList(2) = L2
    Set ObjList(3) = Bref

    PMSY.AppendItems ObjList
End Sub

'剖面索引
Sub PouMianSY()
    Dim p1 As Variant
    p1 = ThisDrawing.Utility.GetPoint(, "剖切索引起点:")
    Dim p2 As Variant
    p2 = ThisDrawing.Utility.GetPoint(p1, "剖切索引中点:")
    Dim L1 As AcadLine
    Set L1 = ThisDrawing.ModelSpace.AddLine(p1, p2)
    Dim a As Double
    a = L1.angle
    Dim PL1 As AcadLWPolyline
    Dim Plist(3) As Double
    Dim Pi As Double
    Pi = Atn(1) * 4
    Dim P11 As Variant
    Dim P22 As Variant
    P11 = GetPointAR(p1, a + Pi / 2, 50): P22 = GetPointAR(p2, a + Pi / 2, 50)
    Plist(0) = P11(0): Plist(1) = P11(1): Plist(2) = P22(0): Plist(3) = P22(1)
    Set PL1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(Plist)
    PL1.SetWidth 0, 50, 50
    PL1.SetWidth 1, 50, 50

    Dim P3 As Variant
    Dim P4 As Variant
    P3 = ThisDrawing.Utility.GetPoint(p2, "索引第一点:")
    Dim L2 As AcadLine
    Set L2 = ThisDrawing.ModelSpace.AddLine(p2, P3)
    P4 = ThisDrawing.Utility.GetPoint(P3, "索引第二点:")
    Dim L3 As AcadLine
    Set L3 = ThisDrawing.ModelSpace.AddLine(P3, P4)
    a = L3.angle
    
    Dim B As AcadBlock
    Set B = ThisDrawing.Blocks.Add(Point3D(0, 0, 0), "*J")
    
    Dim C As Variant
    Dim P5 As Variant
    Dim P6 As Variant
    P6 = Point3D(0, 0, 0)
    C = GetPointAR(P6, a, 500)
    P5 = GetPointAR(P6, a, 1000)
    Dim Circle2 As AcadCircle
    Set Circle2 = B.AddCircle(C, 500)
    Dim L4 As AcadLine
    Set L4 = B.AddLine(P6, P5)
    

    Dim H As Integer
    If a > Pi / 2 And a < 3 * Pi / 2 Then
        H = -100
    Else
        H = 100
    End If


    Dim Att As AcadAttribute
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "索引说明(上)", "节点详见图集")
    Att.Alignment = acAlignmentBottomRight
    Att.Move Att.TextAlignmentPoint, Point3D(P6(0), P6(1) + H, P6(2))
    Att.Rotate Att.TextAlignmentPoint, a
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "索引说明(下)", "苏J01-2003")
    Att.Alignment = acAlignmentTopRight
    Att.Move Att.TextAlignmentPoint, Point3D(P6(0), P6(1) - H, P6(2))
    Att.Rotate Att.TextAlignmentPoint, a
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "序号", "1")
    Att.Alignment = acAlignmentBottomCenter
    Att.Move Att.TextAlignmentPoint, Point3D(C(0), C(1) + H, C(2))
    Att.Rotate Att.TextAlignmentPoint, a
    Set Att = B.AddAttribute(300, acAttributeModeNormal, " ", Point3D(0, 0, 0), "第几页", "10")
    Att.Alignment = acAlignmentTopCenter
    Att.Move Att.TextAlignmentPoint, Point3D(C(0), C(1) - H, C(2))
    Att.Rotate Att.TextAlignmentPoint, a
    
    Dim Bref As AcadBlockReference
    Set Bref = ThisDrawing.ModelSpace.InsertBlock(P4, B.Name, 1, 1, 1, 0)
    
    Dim G As AcadGroup
    Dim ObjList(4) As AcadEntity
    Dim NiMing As String
    NiMing = NiMingZu("平面索引")
 
    Dim PMSY As AcadGroup
    Set PMSY = ThisDrawing.Groups.Add(NiMing)
    Set ObjList(0) = PL1
    Set ObjList(1) = L1
    Set ObjList(2) = L2
    Set ObjList(3) = L3
    Set ObjList(4) = Bref
 
    PMSY.AppendItems ObjList
End Sub


'多行引注
Sub DuoHangYZ()
    On Error GoTo E:
    Dim p1 As Variant
    Dim p2 As Variant
    Dim P3 As Variant
    Dim P4 As Variant
    p1 = ThisDrawing.Utility.GetPoint(, "索引第一点:")
    p2 = ThisDrawing.Utility.GetPoint(p1, "索引第二点:")
    Dim L1 As AcadLine
    Set L1 = ThisDrawing.ModelSpace.AddLine(p1, p2)
    Dim a As Double
    a = L1.angle
    a = a - Atn(1) * 4
    Dim i As Integer
    Dim ObjList() As AcadEntity
    ReDim Preserve ObjList(0)
    Set ObjList(0) = L1
N:
    P3 = ThisDrawing.Utility.GetPoint(p2, "添加注释:")
    i = i + 2
    ReDim Preserve ObjList(i)
    P4 = GetPointAR(p2, a, i * 600 / 2)
    
    Set ObjList(i - 1) = ThisDrawing.ModelSpace.AddLine(P4, GetPointAR(P4, 0, 2000))
    Set ObjList(i) = ThisDrawing.ModelSpace.AddText("XXXXXXXXXX", Point3D(P4(0) + 100, P4(1) + 100, P4(2)), 300)
    GoTo N:
E:
    ReDim Preserve ObjList(i - 2)
    Dim G As AcadGroup
    Set G = ThisDrawing.Groups.Add("*")
    G.AppendItems ObjList
End Sub




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

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

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