Programinha – Mover label de pontos em polilinhas

Bom dia!!!

Hoje vou postar um pequeno programa que me quebra um baita galho!!!

É o seguinte, em poligonais onde queremos mostrar os vértices numerados no civil 3d, normalmente usamos o comando CREATEPTPLYLNCTRVERTAUTO, que cria os pontos automaticamente nos vértices da polilinha.

Até aí tudo bem, veja como fica:

Percebe que a label do ponto fica por cima da linha?

Bem, dá pra criar um estilo que põe o texto mais pra fora, mas isso nem sempre fica bom. E você acaba “estrechando” manualmente a label. Mas e se tiver uns 200 pontos? Aí a coisa começa a ficar chata e você manda o desenhista fazer… hehehehe

Bom, é para isso que este programinha serve, veja:

Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.Civil.DatabaseServices

Public Class MovePtlabels
'pra facilitar em muitos comandos:
Public Function ED() As Editor
Return DOC.Editor
End Function

'devolve o documento atual
Public Function DOC() As Document
Return Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
End Function

'move as labels dos pontos pela bissetriz das arestas
<commandmethod commandflags.nopaperspace="" ovecogolabels="">
Public Sub MoveCogoLabels()

'selecione uma polilinha ou ecerra o comando:
Dim peo As New PromptEntityOptions(vbNewLine & "Selecione a polilinha")
peo.SetRejectMessage("Somente Polilinh")
peo.AddAllowedClass(GetType(Polyline), True)
Dim per As PromptEntityResult = ED.GetEntity(peo)
If per.Status <> PromptStatus.OK Then Exit Sub

'informe uma distância ou encerra o comando:
Dim pdo As New PromptDistanceOptions(vbNewLine & "Indique a distância a afastar")
Dim pdr As PromptDoubleResult = ED.GetDistance(pdo)
If pdr.Status <> PromptStatus.OK Then Exit Sub

'inicia a transação
Using tr = DOC.TransactionManager.StartTransaction
Try

'obtem a polilinha selecionada
Dim pl As Polyline = per.ObjectId.GetObject(OpenMode.ForRead)

'determina se a polilinha está em sentido horário ou antihorário
Dim s As Double = 0
For i = 0 To pl.NumberOfVertices - 1
Dim pa = pl.GetPoint3dAt(i Mod pl.NumberOfVertices)
Dim pb = pl.GetPoint3dAt((i + 1) Mod pl.NumberOfVertices)
s += pa.X * pb.Y - pb.X * pa.Y
Next

'módulo do vetor entre a coordenada do vértice e a coordenada final da label
'leva em conta o sentido da polilinha, para sempre mover para fora dela
Dim f = If(s > 0, -1, 1) * pdr.Value

'itera nos vértices:
For i = 0 To pl.NumberOfVertices - 1
Dim pt As Point3d = pl.GetPoint3dAt(i)

'procura um cogopoint nas coordenadas deste vértice
'aqui podia criar uma query num pointgroup, mas fica como exercício
For Each cid In Autodesk.Civil.ApplicationServices.CivilApplication.ActiveDocument.CogoPoints
Dim cogo As CogoPoint = cid.GetObject(OpenMode.ForWrite)
If cogo.Location <> pt Then Continue For

'se encontrou um cogopoint, calcula a bissetriz das arestas do vértice
Dim pAntes As Point3d = pl.GetPoint3dAt(If(i = 0, pl.NumberOfVertices - 1, i - 1))
Dim pDepois As Point3d = pl.GetPoint3dAt((i + 1) Mod pl.NumberOfVertices)
Dim vAntes As Vector3d = pAntes.GetVectorTo(pt).GetPerpendicularVector
Dim vDepois As Vector3d = pt.GetVectorTo(pDepois).GetPerpendicularVector

'reseta a posição da label antes de reposicionar:
cogo.ResetLabel()

'move a label para a nova posição
cogo.LabelLocation = pt.Add(f * vAntes.Add(vDepois).GetNormal)

Next
Next
'aplica as alterações e faz regen
tr.Commit()
ED.Regen()
Catch
MsgBox(Err.Description)

End Try
End Using
End Sub
End Class

Eu usei o Visual Studio 2010 para compilar a dll e compilei para a versão 2014, que deverá funcionar também no 2015 e 2016.

Agora, é carregar com o NETLOAD e usar, veja o resultado:

Percebe a diferença?

É isso!!!!

Fica com exercício criar um algorítimo mais eficiente para encontrar cogopoints nos vértices da polilinha.

Veja que o programa tem um controle de erros (try, catch) para evitar erros fatais.

Deixe um comentário

Carrinho de compras
Scroll to Top