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
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
a regra é do contratante e não do civil 3d
nao teria problema de me adaptar se fosse exclusivamente coisa do civil 3d
bla, bla, bla… voce nao seria o mesmo anonimo do post sobre cota do greide no alinhamento, seria?
essa regra aprece quando se cria um alinhamento.
suffix ou prefix
simples
sem bla bla bla
É verdade, infelizmente essa regra do nome apareceu somente depois dos alinhamentos já criados
Hopefully you had them change the template to put the alignments on the layer with their name at creation. You can do it in Drawing Settings, Object Layers Tab and using * as the modifier then specifying the Modifier as suffix or prefix.