Civil 3D .Net e alinhamentos

Recentemente no escritório me pediram se tinha jeito de colocar cada alinhamento do desenho em um layer próprio, cujo nome tivesse o nome correspondente a ele. Bem, se fosse um ou dois, era so fazer manualmente, mas no caso eram só 113!!!!

Claaaaaaro!!!!! Nem questionei a utilidade disso, mas em fim...
Suponha que temos o alinhamento A e o B
Eles terão os estilos A e B respectivamente
Cada estilo terá seus layers com o nome A ou B como sufixo....

E isso se aplica não só ao alinhamento, mas também às suas labels....

Bom, como não sou louco de largar isso pro estagiário fazer na mão, coisa que ia levar um mês pelo menos, resolvi criar um programa que o fizesse. E saiu isso aí em baixo:

---

''importa as funções necessárias
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.ApplicationServices.Application
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.DatabaseServices.OpenMode
Imports System
Imports Microsoft.VisualBasci
Imports Autodesk.Civil.DatabaseServices
Imports Autodesk.Civil.Land.DatabaseServicse
Imports Autodesk.Civil.Land.DatabaseServices.Styles
Imports Autodesk.AutoCAD.Colors
Imports Autodesk.Civil
Imports Autodesk.Civil.DatabaseServices.Styles
Imports Autodesk.Civil.ApplicationServices
Imports AcadEntity = Autodesk.AutoCAD.DatabaseServices.Entity
Imports System.Collections.Generic

Public Module CriaESetaEstilos
    Private CurrentTrans As Transaction

    ''verifica a exitencia de um layer, 
    ''se nao existir cria e devolve o id do mesmo
    Private Function AddLayer(ByVal nome As String) As ObjectId
        SymbolUtilityServices.ValidateSymbolName(nome, False)
        Dim TL As LayerTable = DB.LayerTableId.GetObject(ForWrite)
        If Not TL.Has(nome) Then
            Dim l As New LayerTableRecord()
            l.Name = nome
            TL.Add(l)
            CurrentTrans.AddNewlyCreatedDBObject(l, True)
        End If
        Return TL.Item(nome)
    End Function

    Private Function Addlayer(ByVal nome As String,
                              ByVal ltype As String,
                              ByVal cor As Short) As String
        Dim lay As LayerTableRecord = Addlayer(nome).GetObject(ForWrite)
        Try
            lay.Color = Color.FromColorIndex(ColorMethod.ByAci, cor)
            lay.LinetypeObjectId = AddLtype(ltype)
        Catch
            ED.WriteMessage("addlayer({0},{1},{2}) {3}",
                            vbLf, nome, ltype, cor, Err.Description)
        End Try
        Return nome
    End Function

    ''verifica a existencia dum textstyle, se não existir, cria
    Private Function AddTextStyle(ByVal nome As String) As String
        SymbolUtilityServices.ValidateSymbolName(nome, False)
        Dim TL As TextStyleTable = DB.TextStyleTableId.GetObject(ForWrite)
        If Not TL.Has(nome) Then
            Dim l As New TextStyleTableRecord()
            l.Name = nome
            TL.Add(l)
            CurrentTrans.AddNewlyCreatedDBObject(l, True)
        End If
        Return nome
    End Function

    ''veifica a existencia dum linetype, se não existir, cria
    Private Function AddLtype(ByVal nome As String) As ObjectId
        Try
            Dim TL As LinetypeTable = DB.LinetypeTableId.GetObject(ForWrite)
            If Not TL.Has(nome) Then
                Dim l As New LinetypeTableRecord()
                l.Name = nome
                TL.Add(l)
                CurrentTrans.AddNewlyCreatedDBObject(l, True)
            End If
            Return TL.Item(nome)
        Catch
        End Try
        Return ObjectId.Null
    End Function

    ''devolve o nome de uma entidade
    Private Function NameOfObjectID(ByVal id As ObjectId) As String
        Try
            Dim o As Object = id.GetObject(ForRead)
            Return o.Name
        Catch
            ED.WriteMessage(vbLf & "NameOfObjectID : " & Err.Description)
            Return "erro"
        End Try
    End Function

    ''adiciona uma entidade ao modelspace
    Private Function AddToModel(ByVal e As AcadEntity) As ObjectId
        Dim bt As BlockTable = DB.BlockTableId.GetObject(ForRead)
        Dim btr As BlockTableRecord =
            bt(BlockTableRecord.ModelSpace).GetObject(ForWrite)
        AddToModel = btr.AppendEntity(e)
        CurrentTrans.AddNewlyCreatedDBObject(e, True)
    End Function

    ''verifica se um estilo de label qualquer existe
    ''se existir, limpa seus componentes e devolve o estilo
    ''se nao existir, cria e limpa os componentes 
    ''criados por padrao e devolve o estilo
    Private Function GetStyleClear(ByVal col As Object,
                                   ByVal nome As String) As LabelStyle
        ''verifica a existencia
        Try
            GetStyleClear = col.add(nome).getobject(ForWrite)
        Catch
            ''cria, pois ele nao existe
            For Each id In col
                If NameOfObjectID(id) = nome Then
                    GetStyleClear = id.getobject(ForWrite)
                End If
            Next
        End Try

        ''limpa os componentes...
        ''pô autodesk, podia ter um metodo Clear aqui...
        For Each s In New String() {"LINHA", "TEXTO", "Station",
                                    "Geometry Point and Station",
                                    "Line", "Line.1", "Line.2",
                                    "Point of Intersection",
                                    "Text For Each Curve or Sprial"}
            Try
                GetStyleClear.RemoveComponent(s)
            Catch
            End Try
        Next
    End Function

    ''verifica se existe um estilo, se existir devolve o id,
    '' senao cria e devolve o id
    Private Function GetStyle(ByVal col As Object,
                              ByVal nome As String) As ObjectId
        For Each id In col
            If NameOfObjectID(id) = nome Then
                Return id
                Exit For
            End If
        Next
        Return col.add(nome)
    End Function

    ''inicia a transação
    Private Sub StartTR()
        CurrentTrans = AcadDOC.TransactionManager.StartTransaction
    End Sub

    ''finaliza a transação
    Private Sub EndTR()
        CurrentTrans.Commit()
        CurrentTrans.Dispose()
        CurrentTrans = Nothing
    End Sub

    ''documento atual do civil 3d, se tem mais de um desenho ativo, 
    ''devolve aquele de onde o programa foi chamado
    Private Function CivilDOC() As CivilDocument
        Return CivilApplication.ActiveDocument
    End Function

    ''devolve o editor, para fazer pedidos na linha de comando
    ''escrever mensagens...
    Private Function ED() As Editor
        Return AcadDOC.Editor
    End Function

    ''documento atual do autocad, se tem mais de um desenho ativo, 
    ''devolve aquele de onde o programa foi chamado
    Private Function AcadDOC() As Document
        Return DocumentManager.MdiActiveDocument
    End Function

    ''devolve o banco e dados do documento atual
    Private Function DB() As Database
        Return AcadDOC.Database
    End Function


    ''função principal
    <CommandMethod("CriaESetaEstilos")>
    Public Sub CriaESetaEstilos()

        ''inicia a transação
        StartTR()

        ''sempre começar com um TRY
        ''assim, se der erro, o TRY garante uma saida 
        ''do programa com a transação sendo finalizada
        ''se isso nao ocorrer, o autocad vai travar, 
        ''pois ficou aberta a transação

        Try
            ''verifica a existencia do textstyle desejado para as labels
            Dim TEXTSTYLE As String = "R60"
            AddTextStyle(TEXTSTYLE)

            ''predefine os pontos de geometria que serão cotados
            Dim dic As New Dictionary(Of AlignmentPointType, Boolean)
            For Each i In System.Enum.GetValues(
                GetType(AlignmentPointType))
                dic.Item(i) = True
            Next
            ''exclui as lables de mid point
            dic.Item(AlignmentPointType.CurveMidPt) = False


            ''em todos os alinhamentos do desenho, faça
            For Each alinid As ObjectId In CivilDOC.GetAlignmentIds
                ''pegue o alinhamento
                Dim alin As Alignment = alinid.GetObject(ForWrite)

                ''remova todas as labels soltas associadas a ele
                For Each id As ObjectId In alin.GetLabelIds
                    Dim l As Label = id.GetObject(ForWrite)
                    l.Erase()
                Next

                ''crie templates para os nomes dos layers
                Dim sname As String =
                    alin.Name.ToUpper.Replace("EIXO", "").Replace("ACESSO", "").Trim(" ")
                Dim stipo As String = If(alin.Name.ToUpper.Contains("ACESSO"), "A", "")

                ''layer do eixo do alinhamento
                Dim LAYER_EIXO As String =
                    AddLayer(sname, "TRACO-PONTO",
                             If(alin.Name.Contains("ACESSO"), 5, 6))

                ''layer das extension lines, que serao 
                ''substituidas por labels de intersectionpoint
                Dim LAYER_INTERSECTIONPOINT As String =
                    AddLayer("BG" & stipo & "IC-" & alin.Name, "CONTINUO", 7)

                ''layer do major station
                ''como a linha tem q ser em layer diferente do texto,
                '' podemos criar 2 estilos e nao usar estilo para 
                ''minor station, ja que podemos alterar a frequenciada labels
                ''lembrando que uma label so adimite um layer
                Dim LAYER_MAJORSTATION_TEXT As String =
                    AddLayer("BG" & stipo & "R60-" & sname, "CONTINUO", 3)
                Dim LAYER_MAJORSTATION_LINE As String =
                    AddLayer("BG" & stipo & "FET-" & sname, "CONTINUO", 3)

                ''labels dos geometry point
                Dim LAYER_GEOMETRYPOINT_LINE As String =
                    AddLayer("BG" & stipo & "IC-" & sname, "CONTINUO", 7)
                Dim LAYER_GEOMETRYPOINT_TEXT As String =
                    AddLayer("BG" & stipo & "ICR60-" & sname, "CONTINUO", 7)

                ''redefina o estilo do alinhamento e o seu layer atual
                alin.StyleId =
                    Cria_AlignmentStyle(alin, alin.Name, LAYER_EIXO)
                alin.Layer = LAYER_EIXO

                ''adiciona label nos intersection points (PIs)
                Adiciona_PointIntersectionLabel(alin,
                      Cria_PointIntersectionLabelStyle(alin,
                                                       alin.Name,
                                                       LAYER_INTERSECTIONPOINT))

                ''label set do alinhamento
                ''pega:
                Dim LBS As AlignmentLabelSetStyle =
                    GetStyle(CivilDOC.Styles.LabelSetStyles.AlignmentLabelSetStyles,
                             alin.Name).GetObject(ForWrite)
                ''agora limpa os componentes
                While LBS.Count > 0
                    LBS.RemoveAt(0)
                End While

                ''cria as labels de major station
                ''texto
                LBS.Add(Cria_MajorStationText(alin.Name & "-texto",
                                              LAYER_MAJORSTATION_TEXT, TEXTSTYLE))
                LBS.Item(LBS.Count - 1).Increment = 100
                ''linha
                LBS.Add(Cria_MajorStationLine(alin.Name & "-linha",
                                              LAYER_MAJORSTATION_LINE))

                LBS.Item(LBS.Count - 1).Increment = 20

                ''cria as labels degeometry point
                ''texto
                LBS.Add(Cria_GeometryPointLabelText(alin.Name & "-texto",
                                                    LAYER_GEOMETRYPOINT_TEXT, "R60"))
                LBS.Item(LBS.Count - 1).SetLabeledAlignmentGeometryPoints(dic)
                ''linha
                LBS.Add(Cria_GeometryPointLabeLine(alin.Name & "-linha",
                                                   LAYER_GEOMETRYPOINT_LINE))
                LBS.Item(LBS.Count - 1).SetLabeledAlignmentGeometryPoints(dic)

                alin.ImportLabelSet(LBS.ObjectId)
                ''redefine os layers dos labels adicionados pelo labelset
                Redefine_LabelSet_Layers(alin)
            Next

            MsgBox("fim")
        Catch
            ED.WriteMessage(vbLf & Err.Description)
        End Try
        EndTR()
    End Sub

    ''cria um alignmentstyle e devolve o seu id
    ''StNamne é o nome do estilo
    Private Function Cria_AlignmentStyle(ByVal alin As Alignment,
                                         ByVal StName As String,
                                         ByVal layer As String) As ObjectId

        ''cria ou pega o estilo
        Cria_AlignmentStyle = GetStyle(CivilDOC.Styles.AlignmentStyles, StName)
        Dim alstyle As AlignmentStyle = Cria_AlignmentStyle.GetObject(ForWrite)

        ''redefine as propriedades do mesmo
        With alstyle
            ''eixo principal
            .GetDisplayStylePlan(AlignmentDisplayStyleType.Line).Layer = layer
            .GetDisplayStylePlan(AlignmentDisplayStyleType.Curve).Layer = layer
            .GetDisplayStylePlan(AlignmentDisplayStyleType.Spiral).Layer = layer

            ''demais items da aba display do estilo do alinhamento
            .GetDisplayStylePlan(AlignmentDisplayStyleType.Arrow).Visible = False
            Try
                .GetDisplayStylePlan(AlignmentDisplayStyleType.WarningSymbol).Visible = False
            Catch
                '' ED.WriteMessage(vbLf & Err.Description & vbLf)
            End Try

            ''define todos para bylayer
            For Each i As AlignmentDisplayStyleType In
                System.Enum.GetValues(GetType(AlignmentDisplayStyleType))
                .GetDisplayStylePlan(i).Linetype = "Bylayer"
                .GetDisplayStylePlan(i).LinetypeScale = 1
                .GetDisplayStylePlan(i).Lineweight = LineWeight.ByLayer
            Next

            ''desliga os line extension
            .GetDisplayStylePlan(AlignmentDisplayStyleType.LineExtensions).Visible = False
            .GetDisplayStylePlan(AlignmentDisplayStyleType.CurveExtensions).Visible = False

            ''items da aba marker do estilo de alinhamento
            .BeginPointMarkerStyle = ObjectId.Null
            .CompoundCurveIntersectPointMarkerStyle = ObjectId.Null
            .CurveLineIntersectPointMarkerStyle = ObjectId.Null
            .CurveSpiralIntersectPointMarkerStyle = ObjectId.Null
            .EndPointMarkerStyle = ObjectId.Null
            .IntersectionPointMarkerStyle = ObjectId.Null
            .LineCurveIntersectPointMarkerStyle = ObjectId.Null
            .LineSpiralIntersectPointMarkerStyle = ObjectId.Null
            .MidPointMarkerStyle = ObjectId.Null
            .ReverseCurveIntersectPointMarkerStyle = ObjectId.Null
            .ReverseSpiralIntersectPointMarkerStyle = ObjectId.Null
            .SpiralCurveIntersectPointMarkerStyle = ObjectId.Null
            .SpiralLineIntersectPointMarkerStyle = ObjectId.Null
            .SpiralSpiralIntersectPointMarkerStyle = ObjectId.Null
            .StationReferencePointMarkerStyle = ObjectId.Null
            .ThroughPointMarkerStyle = ObjectId.Null
        End With
    End Function

    ''cria um PointIntersectionLabelStyle
    Private Function Cria_PointIntersectionLabelStyle(ByVal alin As Alignment,
                                                      ByVal StName As String,
                                                      ByVal layer As String) As LabelStyle

        ''cria ou pega o estilo
        ''sem nenhum componente
        Dim LB As LabelStyle =
            GetStyleClear(CivilDOC.Styles.LabelStyles.
                          AlignmentLabelStyles.PointOfIntersectionLabelStyles,
                          StName)

        ''define o layer
        LB.Properties.Label.Layer.Value = layer

        ''cria um componente de linha do PI ao PC
        Dim linha1 As LabelStyleLineComponent =
            LB.AddComponent("Line.1", LabelStyleComponentType.Line).GetObject(ForWrite)
        With linha1
            .General.Visible.Value = True
            .General.StartAnchorPoint.Value = AnchorPointType.PointOfIntersection
            .General.UseEndPointAnchor.Value = True
            .General.EndAnchorPoint.Value = AnchorPointType.TangentInStart
            .Line.LengthType.Value = LabelStyleLengthType.FixedLength
            .Line.FixedLength.Value = 0.01
            .Line.Color.Value = Color.FromColorIndex(ColorMethod.ByAci, 256)
        End With

        ''cria um componente de linha do PI ao PT
        Dim linha2 As LabelStyleLineComponent =
            LB.AddComponent("Line.2", LabelStyleComponentType.Line).GetObject(ForWrite)
        With linha2
            .General.Visible.Value = True
            .General.StartAnchorPoint.Value = AnchorPointType.PointOfIntersection
            .General.UseEndPointAnchor.Value = True
            .General.EndAnchorPoint.Value = AnchorPointType.TangentOutEnd
            .Line.LengthType.Value = LabelStyleLengthType.FixedLength
            .Line.FixedLength.Value = 0.01
            .Line.Color.Value = Color.FromColorIndex(ColorMethod.ByAci, 256)
        End With

        ''devolve o estilo
        Return LB
    End Function

    ''adiciona o PointIntersectionLabel
    Private Sub Adiciona_PointIntersectionLabel(ByVal alin As Alignment,
                                                ByVal lb As LabelStyle)
        ''em todas as entidades do alinhamento, faça
        For Each E In alin.Entities
            Dim oid As ObjectId = ObjectId.Null
            ''tente adicionar uma label do tipo PointIntersectionLabel 
            ''elas so podem ser feitas em 3 tipos de entidade de alinhamento
            If E.EntityType = AlignmentEntityType.Arc Then
                oid = AlignmentIndexedPILabel.Create(DirectCast(E, AlignmentArc),
                                                     lb.ObjectId)
            ElseIf E.EntityType = AlignmentEntityType.SpiralCurveSpiral Then
                oid = AlignmentIndexedPILabel.Create(DirectCast(E, AlignmentSCS),
                                                     lb.ObjectId)
            End If

            ''se a label foi criada, redefina o seu layer
            If oid <> ObjectId.Null Then
                Dim o As AlignmentIndexedPILabel = oid.GetObject(ForWrite)
                o.Layer = lb.Properties.Label.Layer.Value
            End If
        Next

        ''força uma atualização do alinhamento, senão as labels na aparecem na tela...
        alin.Update()
    End Sub

    ''cria label major station de alinhamento com componente de texto somente
    Private Function Cria_MajorStationText(ByVal StName As String,
                                           ByVal layer As String,
                                           ByVal textstyle As String) As ObjectId
        Dim ST As LabelStyle =
        GetStyleClear(CivilDOC.Styles.LabelStyles.
                      AlignmentLabelStyles.MajorStationLabelStyles, StName)
        ST.Properties.Label.Layer.Value = layer
        ST.Properties.Label.TextStyle.Value = textstyle


        Dim texto As LabelStyleTextComponent =
            ST.AddComponent("TEXTO", LabelStyleComponentType.Text).GetObject(ForWrite)
        With texto
            .General.Visible.Value = True
            .Text.Contents.Value = "<[Station Value(Um|FSI|P0|RN|AP|Sn|TP|EN|DZY|W0|OLB)]>"
            .Text.Height.Value = 0.002
            .Text.Angle.Value = 0
            .Text.XOffset.Value = 0
            .Text.YOffset.Value = -0.002
            .Text.Attachment.Value = LabelTextAttachmentType.TopCenter
            .Text.Color.Value = Color.FromColorIndex(ColorMethod.ByAci, 256)
        End With

        Return ST.ObjectId
    End Function

    ''cria label major station de alinhamento com componente de linha somente
    Private Function Cria_MajorStationLine(ByVal StName As String,
                                           ByVal layer As String) As ObjectId
        Dim ST As LabelStyle =
            GetStyleClear(CivilDOC.Styles.LabelStyles.
                          AlignmentLabelStyles.MajorStationLabelStyles, StName)
        ST.Properties.Label.Layer.Value = layer

        Dim linha As LabelStyleLineComponent =
            ST.AddComponent("LINHA", LabelStyleComponentType.Line).GetObject(ForWrite)
        With linha
            .General.Visible.Value = True
            .General.StartAnchorPoint.Value = AnchorPointType.Station
            .General.UseEndPointAnchor.Value = False
            .Line.Angle.Value = -Math.PI / 2
            .Line.FixedLength.Value = 0.002
            .Line.Color.Value = Color.FromColorIndex(ColorMethod.ByAci, 256)
        End With

        Return ST.ObjectId
    End Function

    ''cria label major station de alinhamento com componente de linha somente
    Private Function Cria_GeometryPointLabelText(ByVal StName As String,
                                                 ByVal layer As String,
                                                 ByVal textstyle As String) As ObjectId
        Dim ST As LabelStyle =
            GetStyleClear(CivilDOC.Styles.LabelStyles.
                          AlignmentLabelStyles.GeometryPointLabelStyles, StName)
        ST.Properties.Label.Layer.Value = layer
        ST.Properties.Label.TextStyle.Value = textstyle

        Dim texto As LabelStyleTextComponent =
            ST.AddComponent("TEXTO", LabelStyleComponentType.Text).GetObject(ForWrite)

        texto.General.Visible.Value = True

        With texto.Text
            .Contents.Value =
                "<[Geometry Point Text(CP)]>=EST <[Station Value(Um|FSI|P2|RN|AC|Sn|TP|EN|DZN|W0|OF)]>"
            .Height.Value = 0.002
            .Angle.Value = Math.PI / 2
            .XOffset.Value = 0
            .YOffset.Value = -0.04
            .Attachment.Value = LabelTextAttachmentType.BottomLeft
            .Color.Value = Color.FromColorIndex(ColorMethod.ByAci, 256)
        End With

        Return ST.ObjectId
    End Function

    ''cria label major station de alinhamento com componente de linha somente
    Private Function Cria_GeometryPointLabeLine(ByVal StName As String,
                                                ByVal layer As String) As ObjectId
        Dim ST As LabelStyle =
            GetStyleClear(CivilDOC.Styles.LabelStyles.
                          AlignmentLabelStyles.GeometryPointLabelStyles, StName)

        ST.Properties.Label.Layer.Value = layer

        Dim linha As LabelStyleLineComponent =
            ST.AddComponent("LINHA", LabelStyleComponentType.Line).
            GetObject(ForWrite)
        With linha
            .General.Visible.Value = True
            .General.StartAnchorPoint.Value = AnchorPointType.Station
            .General.UseEndPointAnchor.Value = False
            .Line.Angle.Value = -Math.PI / 2
            .Line.FixedLength.Value = 0.04
            .Line.Color.Value = Color.FromColorIndex(ColorMethod.ByAci, 256)
        End With

        Return ST.ObjectId
    End Function

    ''Redefine Layers do label set aplicado ao alinhamento
    Private Sub Redefine_LabelSet_Layers(ByVal alin As Alignment)
        ''em todas as labelgroups, faça
        For Each oid As ObjectId In alin.GetLabelGroupIds
            ''pegue o labelgropu
            Dim l As AlignmentLabelGroup = oid.GetObject(ForWrite)

            ''pegue o seu estilo
            Dim lb As LabelStyle = l.StyleId.GetObject(ForRead)
            ''descubra e sete o layer
            l.Layer = lb.Properties.Label.Layer.Value

            ''impede que o label de texto de major station escreva 
            ''label no inicio e no fim do alinhamento
            ''já que o geometry point faz isso
            If l.LabelType = LabelType.AlignmentMajorStation And
                l.StyleName.EndsWith("texto") Then
                Try
                    l.RangeEndFromFeature = False
                    l.RangeEnd = Math.Floor(alin.EndingStation / 100) * 100
                Catch
                End Try
                Try
                    l.RangeStartFromFeature = False
                    l.RangeStart =
                        (1 + Math.Floor(alin.StartingStation / 100)) * 100
                Catch
                End Try
            End If
        Next
    End Sub
End Module

---

Faz o teste... Crie alguns alinhamentos, compile o código e rode ele...

Serão criados estilos para:

• Alinhamento
• Major Station
• Geometry Point
• Alignment Label Set
• Point of Intersection

Cada item com um layer específico e para cada alinhamento!!!

O código está todo comentado. Ah, rodei no 2012, possivelmente funcione no 2011 também com pouquíssimas alterações