'创建平面索引
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