'创建平面索引
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 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 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
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
|
暂时没有评论
发表评论 - 不要忘了输入验证码哦! |