Macro VBA para extrair/inserir coordenadas dos vértices de uma polyline

[Anonymous]

Olá, gostaria de duas dicas:

A primeira seria para exportar para Excel as coordenadas dos vértices de uma polyline.

A segunda seria para inserir blocos nos vértices de uma polyline.

[grobnik]

See code for first step

Sub TestObjcetctPolyline()
Dim ObjExcel As Object
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim ReturnObj As AcadObject
Dim BasePnt As Variant
Dim MyCoords As Variant

Set ObjExcel = CreateObject("Excel.Application")
Set xlBook = ObjExcel.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
ObjExcel.Visible = True
ObjExcel.Workbooks(ObjExcel.ActiveWorkbook.Name).Activate


ThisDrawing.Utility.GetEntity ReturnObj, BasePnt, "Select an object"
If TypeOf ReturnObj Is AcadLWPolyline Then
    Set MyObj = ReturnObj
    MyCoords = MyObj.Coordinates
    MyCoordsCount = UBound(MyCoords)
    For X = 0 To MyCoordsCount
        ObjExcel.Range("A" & X + 1).Value = "COORDS " & X
        ObjExcel.Range("B" & X + 1).Value = MyCoords(X)
    Next
End If

End Sub

[grobnik]

The above code allows to select a LWPolyline o screen, create a new Excel session and transfer coordinates.

Of course you can do the opposite, selecting a LWPolyline and add vertex to your polyline just selected catching data from Excel.

I'll show you the code soon, now I'm little bit busy.

-From Google Translator-

El código anterior permite seleccionar una pantalla LWPolyline o, crear una nueva sesión de Excel y transferir coordenadas. Por supuesto, puede hacer lo contrario, seleccionando una LWPolyline y agregue vértice a su polilínea que acaba de seleccionar capturando datos de Excel. Te mostraré el código pronto, ahora estoy un poco ocupado.

[grobnik]

Sub TestObjcetctPolyline()
Dim ObjExcel As Object
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim ReturnObj As AcadObject
Dim BasePnt As Variant
Dim MyCoords As Variant

Set ObjExcel = CreateObject("Excel.Application")
Set xlBook = ObjExcel.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
ObjExcel.Visible = True
ObjExcel.Workbooks(ObjExcel.ActiveWorkbook.Name).Activate


ThisDrawing.Utility.GetEntity ReturnObj, BasePnt, "Select an object"
If TypeOf ReturnObj Is AcadLWPolyline Then
    Set MyObj = ReturnObj
    MyCoords = MyObj.Coordinates
    MyCoordsCount = UBound(MyCoords)
    For X = 0 To MyCoordsCount
        ObjExcel.Range("A" & X + 1).Value = "COORDS " & X
        ObjExcel.Range("B" & X + 1).Value = MyCoords(X)
    Next
End If
    ' ADD Vertex to Polyline
    ' Define the new vertex
    Dim newVertex(0 To 1) As Double
    Dim MyString As Variant
    Dim MyString1 As Variant
    
    MyString = ObjExcel.Range("B" & MyCoordsCount + 1).Value
    newVertex(0) = Format(MyString, "##,##0.00")
        
    MyString1 = ObjExcel.Range("B" & MyCoordsCount + 2).Value
    newVertex(1) = Format(MyString, "##,##0.00")

    
    ' Add the vertex to the polyline
    MyObj.AddVertex 1, newVertex
    MyObj.Update
    MsgBox "Vertex added.", , "AddVertex Example"

End Sub

[Anonymous]

grobnik,

Muito obrigado por compartilhar seu conhecimento.

A rotina funcionou perfeitamente, gerando os vértices, porém seria necessário que as coordenadas "X" e "Y" fossem transportadas para mesma linha, para que a referência de cada vértice se encontre em uma única linha.

Assim, posteriormente será convertida as coordenadas UTM para Geográficas Decimal e criado um desenho com alguns atributos, que deverá ser transformado em bloco. Com a posição inicial obtida pela polyline, será inserido no CAD o bloco com as informações finais.

Mais uma vez, Obrigado, abraço! 

[grobnik]

Hi,

look at this post for coordinates translation, may helps you more

https://forums.autodesk.com/t5/vba/extracting-polyline-coordinates-problem/m-p/9503424#M103757

[grobnik · Accepted solution]

Here code for text in column

Sub TestObjcetctPolyline()
Dim ObjExcel As Object
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim ReturnObj As AcadObject
Dim BasePnt As Variant
Dim MyCoords As Variant

Set ObjExcel = CreateObject("Excel.Application")
Set xlBook = ObjExcel.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
ObjExcel.Visible = True
ObjExcel.Workbooks(ObjExcel.ActiveWorkbook.Name).Activate


ThisDrawing.Utility.GetEntity ReturnObj, BasePnt, "Select an object"
If TypeOf ReturnObj Is AcadLWPolyline Then
    Set MyObj = ReturnObj
    MyCoords = MyObj.Coordinates
    MyCoordsCount = UBound(MyCoords)
    ObjExcel.Range("A1").Value = "COORDS X"
    ObjExcel.Range("B1").Value = "COORDS Y"
    On Error Resume Next
    X = 0
    Y = 1
           
    For I = 0 To MyCoordsCount / 2
        ObjExcel.Range("A" & I + 2).Value = MyCoords(X)
        ObjExcel.Range("B" & I + 2).Value = MyCoords(Y)
        
        If Err Then Err.Clear
               
        X = X + 2
        Y = Y + 2
               
    Next
End If

End Sub