Programinha – Mover label de pontos em polilinhas

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