Retangulos e vb.net

Que tal desenhar retângulos com VB.NET em qualquer ângulo?
Veja o programa abaixo:
mais...


'importa as dependencias


Imports Autodesk.AutoCAD.DatabaseServices


Imports Autodesk.AutoCAD.Runtime


Imports Autodesk.AutoCAD.Geometry


Imports Autodesk.AutoCAD.ApplicationServices


Imports Autodesk.AutoCAD.EditorInput


 


Public Class TestEntityJig


 


    'classe que faz o prompt do terceiro ponto, strechando o retângulo:


    Private Class GetPoint2Jig


        'herda estas caracteristicas:


        Inherits EntityJig


 


        'variaveis globais desta classe:


        Private pta, ptb, ptc As Point3d 'pontos que formam o retângulo


        Private msg As String


 


        Public Sub New(ByVal pt1 As Point3d, ByVal pt2 As Point3d, ByVal message As String)


            'cria uma pline virtual:


            MyBase.New(New Polyline(4))


            With DirectCast(Entity, Polyline)


                .AddVertexAt(0, New Point2d(pt1.X, pt1.Y), 0, 0, 0)


                .AddVertexAt(0, New Point2d(pt2.X, pt2.Y), 0, 0, 0)


                .AddVertexAt(0, New Point2d(pt2.X, pt2.Y), 0, 0, 0)


                .AddVertexAt(0, New Point2d(pt1.X, pt1.Y), 0, 0, 0)


                .Closed = True


            End With


            'inicializa as variaveis globais


            msg = message


            pta = pt1


            ptb = pt2


 


        End Sub


 


        'função que atualiza a variavel PTC, que é usada para redesenhar o retângulo


        Protected Overrides Function Sampler(ByVal prompts As JigPrompts) As SamplerStatus


            Dim jigOpts As New JigPromptPointOptions(msg)


            jigOpts.UserInputControls = UserInputControls.Accept3dCoordinates


 


            Dim dres As PromptPointResult = prompts.AcquirePoint(jigOpts)


            ptc = dres.Value


 


            If dres.Status = PromptStatus.Cancel Then


                Return SamplerStatus.Cancel


            Else


                Return SamplerStatus.OK


            End If


        End Function


 


        'função que atualizao retângulo


        Protected Overrides Function Update() As Boolean


            'angulo do vetor BA


            Dim ang_ab As Double = Math.Atan2(ptb.Y - pta.Y, ptb.X - pta.X)


 


            'angulo interno dos vetores AB e AC


            Dim ang_abc As Double = Math.Atan2(ptc.Y - pta.Y, ptc.X - pta.X) - ang_ab


 


            'distancia do ponto A ao B


            Dim d_ab As Double = pta.DistanceTo(ptc) * Math.Sin(ang_abc)


 


            'angulo perpendicular ao vetor AB


            Dim ang_ac = ang_ab + Math.PI / 2


 


            'delta das coordenadas (nao achei uma função polar...):


            Dim dx As Double = d_ab * Math.Cos(ang_ac)


            Dim dy As Double = d_ab * Math.Sin(ang_ac)


 


            'atualiza o retangulo


            Try


                With DirectCast(Entity, Polyline)


                    .SetPointAt(2, New Point2d(ptb.X + dx, ptb.Y + dy))


                    .SetPointAt(3, New Point2d(pta.X + dx, pta.Y + dy))


                End With


            Catch generatedExceptionName As System.Exception


                Return False


            End Try


            Return True


 


        End Function


 


        'função que devolve a polilinha virtual


        Public Function Get_Entity() As Polyline


            Return DirectCast(Entity, Polyline)


        End Function


    End Class


 


    'comando a ser usado na linha de comando:


    <CommandMethod("ret")> _


    Public Shared Sub ret()


        Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor


 


        'pede o primeiro ponto


        Dim res1 As PromptPointResult = ed.GetPoint(vbLf & "Ponto 1:")


        If res1.Status <> PromptStatus.OK Then Exit Sub


 


        'pede o segundo ponto


        Dim opts As New PromptPointOptions(vbLf & "Ponto 2:")


        opts.BasePoint = res1.Value


        opts.UseBasePoint = True


        Dim res2 As PromptPointResult = ed.GetPoint(opts)


        If res2.Status <> PromptStatus.OK Then Exit Sub


 


        'pede o terceiro ponto, modificando o retangulo


        'conforme o mouse mexe:


        Dim jig As New GetPoint2Jig(res1.Value, res2.Value, vbLf & "Ponto 3")


        Dim res As PromptResult = ed.Drag(jig)


 


 


        If res.Status = PromptStatus.OK Then


            'tudo certo, adiciona a polilina ao modelspace:


            Dim pline As Polyline = jig.Get_Entity


            Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database


            Dim tm As Autodesk.AutoCAD.DatabaseServices.TransactionManager = db.TransactionManager


            Dim ta As Transaction = tm.StartTransaction()


 


            Try


                Dim bt As BlockTable = tm.GetObject(db.BlockTableId, OpenMode.ForRead, False)


                Dim btr As BlockTableRecord = tm.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite, False)


                Dim lineid As ObjectId = btr.AppendEntity(pline)


                tm.AddNewlyCreatedDBObject(pline, True)


                ta.Commit()


            Finally


                ta.Dispose()


            End Try


 


        End If


    End Sub


End Class



Com ele dá pra fazer isso:

Baixe o programa pronto aqui (autocad 2008 em diante, ok?), para usar, descompacte a dll em algum lugar, e use o comando NETLOAD para carregar a DLL, depois digite RET na linha de comando.

Um comentário: