Author Topic: Excel VBA to Select polyline and bring area back to excel  (Read 22431 times)

0 Members and 1 Guest are viewing this topic.

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Excel VBA to Select polyline and bring area back to excel
« on: March 06, 2014, 01:26:22 PM »
Is there an excel vba that if I push a button, that it will go to the autocad session and I would pick a polyline(s) then report the values back to the excel spreadsheet where I started? (Area, z, etc.)?
Civil3D 2020

RICVBA

  • Newt
  • Posts: 62
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #1 on: March 06, 2014, 02:02:37 PM »
Option Explicit

Code: [Select]
Sub PickLwPolyAndGetData()
   
    Dim MyCell As Range
    Dim ACAD As AcadApplication
    Dim LWPoly As AcadLWPolyline
    Dim ThisDrawing As AcadDocument
    Dim Pt1 As Variant
    Dim LWArea As Double, LWZ As Double

    ' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
        Set ACAD = New AcadApplication
        ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
         
   
    ' select LwPolyline
    On Error Resume Next
    Do
        Err.Clear
        ThisDrawing.Utility.GetEntity LWPoly, Pt1, "Select a Polyline:"
    Loop While Err
    On Error GoTo 0
   
   
    'get LWPoly data
    With LWPoly
        LWArea = .Area
        LWZ = .Elevation
    End With
   
    ' write LWPoly data on worksheet
    Set MyCell = ActiveCell
    With MyCell
        .Offset(0, 0).Value = "Area:"
        .Offset(0, 1).Value = LWArea
        .Offset(1, 0) = "Z:"
        .Offset(1, 0) = LWZ
    End With
   
    Set ThisDrawing = Nothing
    Set ACAD = Nothing
   
 End Sub

bye

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #2 on: March 06, 2014, 02:07:02 PM »
Way cool. Can I have the user select a bunch of polylines at once?
Civil3D 2020

RICVBA

  • Newt
  • Posts: 62
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #3 on: March 06, 2014, 03:57:26 PM »
Sure. The simplest way could be enclose in a "do while" loop the code lines between "'select LWPolyline" to the 2nd "end with". With a proper "while" condition.
Otherwise you could add a selectionset on screen and then loop through the LWPolylines gathered this way.

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #4 on: March 06, 2014, 04:00:09 PM »
Could I ask for an example if you do not mind? What you did is a huge stepping stone!

We have some polylines that have areas that we need to put into spreadsheets
Civil3D 2020

RICVBA

  • Newt
  • Posts: 62
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #5 on: March 07, 2014, 02:04:37 AM »
try this one
Code: [Select]
Sub PickLwPolysAndGetData()
   
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range

'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline

' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant

'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double


' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
        Set ACAD = New AcadApplication
        ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
     

' selecting LwPolylines on screen by selelection set filtering method
    ' managing potential selection set exsistence
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
    On Error GoTo 0
    ssetObj.Clear
   
    'setting filtering critera
    gpCode(0) = 0
    dataValue(0) = "LWPOLYLINE"
   
    'selecting LWPolylines
    ssetObj.SelectOnScreen gpCode, dataValue

' processing LWPolylines

    If ssetObj.Count > 0 Then
   
        ' writing sheet headings
        Set MySht = ActiveSheet
        Set MyCell = MySht.Cells(1, 1)
        With MyCell
            .Offset(0, 0).Value = "LWPoly nr"
            .Offset(0, 1).Value = "Area"
            .Offset(0, 2) = "Z"
        End With
       
        'clearing previous written data
        iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
        If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear
       
        'retrieving LWPolys data and writing them on worksheet
        iRow = 1
        For Each LWPoly In ssetObj
            'retrieving LWPoly data
            With LWPoly
                LWArea = .Area
                LWZ = .Elevation
            End With
           
            ' writing LWPoly data
            With MyCell
                .Offset(iRow, 0).Value = "LWPoly nr." & iRow
                .Offset(iRow, 1).Value = LWArea
                .Offset(iRow, 2) = LWZ
            End With
            iRow = iRow + 1
        Next LWPoly
       
    End If

' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing

End Sub
bye

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #6 on: March 08, 2014, 03:01:10 PM »
Nice! Thank you for sharing! When it looks for areas on the same elevation... can it automatically add those areas together before placing it in a cell?
Civil3D 2020

RICVBA

  • Newt
  • Posts: 62
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #7 on: March 10, 2014, 03:53:12 AM »
it's much simplier done directly in excel by means of some SUM.IF function that reads column C values ("Z" values) and sums corresponding column B values ("Area" values)

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #8 on: April 16, 2014, 04:10:44 PM »
Well. I upgraded to the next cad version! Anyways, now when I run my macro I get an error

Run-time '13':
Type mismatch

debug:

Code: [Select]
For Each LWPoly In ssetObj
Any help would be great! It did work in the previous cad version.




Code: [Select]
Sub Import_POLYLINES()
   
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As range

'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline

' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant

'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double


' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
        Set ACAD = New AcadApplication
        ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
     

' selecting LwPolylines on screen by selelection set filtering method
    ' managing potential selection set exsistence
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
    On Error GoTo 0
    ssetObj.Clear
   
    'setting filtering critera
    gpCode(0) = 0
    dataValue(0) = "LWPOLYLINE"
   
    'selecting LWPolylines
    ssetObj.SelectOnScreen gpCode, dataValue

' processing LWPolylines

    If ssetObj.Count > 0 Then
   
        ' writing sheet headings
        Set MySht = ActiveSheet
        Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
        With MyCell
            '.Offset(0, 0).Value = "LWPoly nr"
            '.Offset(0, 1).Value = "Area S.F."
            '.Offset(0, 0) = "Elevation"
        End With
       
        'clearing previous written data
        iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
        If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
       
        'retrieving LWPolys data and writing them on worksheet
        iRow = 1
        For Each LWPoly In ssetObj
       
            'retrieving LWPoly data
            With LWPoly
                LWArea = .area
                LWZ = .Elevation
            End With
           
             ' writing LWPoly data
            With MyCell
                '.Offset(iRow, 0).Value = "LWPoly nr." & iRow
                .Offset(iRow, 1).Value = LWArea
                .Offset(iRow, 0) = LWZ
            End With
            iRow = iRow + 1
       Next LWPoly
       
   End If

' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing

End Sub
Civil3D 2020

fixo

  • Guest
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #9 on: April 16, 2014, 08:36:17 PM »
Instead of:
For Each LWPoly In ssetObj...
use this way:
Dim oEnt as acadentity
For Each oEnt in ssetObj
if typeof oEnt is AcadLWpolyline then
Set LWPoly=ent
...
'' some rest work with polyline
end if
next

Something like this, just from the memory

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #10 on: April 16, 2014, 09:45:19 PM »
Thank you so much. I will see if I can get this to work tomorrow. I will let you know my results!
Civil3D 2020

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #11 on: April 17, 2014, 09:21:28 AM »
Well, I tried and I am still getting the same error in the same location... Weird. Do you see anything that is incorrect?

Code: [Select]
Sub Import_POLYLINES()
   
   
'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As range

'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim oEnt As AcadEntity

' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant

'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWZ As Double


' Autocad Session handling
    On Error Resume Next
    Set ACAD = GetObject(, "AutoCAD.Application")
    On Error GoTo 0
    If ACAD Is Nothing Then
        Set ACAD = New AcadApplication
        ACAD.Visible = True
    End If
    Set ThisDrawing = ACAD.ActiveDocument
     

' selecting LwPolylines on screen by selelection set filtering method
    ' managing potential selection set exsistence
    On Error Resume Next
    Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
    If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
    On Error GoTo 0
    ssetObj.Clear
   
    'setting filtering critera
    gpCode(0) = 0
    dataValue(0) = "LWPOLYLINE"
   
    'selecting LWPolylines
    ssetObj.SelectOnScreen gpCode, dataValue

' processing LWPolylines

    If ssetObj.Count > 0 Then
   
        ' writing sheet headings
        Set MySht = ActiveSheet
        Set MyCell = MySht.Cells(11, 1) 'Where to Start the Excel Cell Input X, Y
        With MyCell
            '.Offset(0, 0).Value = "LWPoly nr"
            '.Offset(0, 1).Value = "Area S.F."
            '.Offset(0, 0) = "Elevation"
        End With
       
        'clearing previous written data
        iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
        If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 2).Clear
       
        'retrieving LWPolys data and writing them on worksheet
        iRow = 1
        For Each oEnt In ssetObj
        If TypeOf oEnt Is AcadLWPolyline Then
        Set LWPoly = oEnt
       
            'retrieving LWPoly data
            With LWPoly
                LWArea = .area
                LWZ = .Elevation
            End With
           
             ' writing LWPoly data
            With MyCell
                '.Offset(iRow, 0).Value = "LWPoly nr." & iRow
                .Offset(iRow, 1).Value = LWArea
                .Offset(iRow, 0) = LWZ
            End With
            iRow = iRow + 1
           
            End If
       
       Next oEnt
       
   End If

' cleaning up before ending
    ssetObj.Delete
    Set ssetObj = Nothing
    Set ThisDrawing = Nothing
    Set ACAD = Nothing

End Sub
Civil3D 2020

RICVBA

  • Newt
  • Posts: 62
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #12 on: April 17, 2014, 05:52:30 PM »
Does it compile ok?

MSTG007

  • Gator
  • Posts: 2598
  • I can't remeber what I already asked! I need help!
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #13 on: April 18, 2014, 07:15:54 AM »
Yes it does compile ok. I can get through the macro up to that one point were the debugger appears. It was working on 2013 without a problem that I know of. But since we upgraded to 2014 it bugs out. All my references are updated as well. I have the parcel macro that I did update and works (slowly) with 2014. I just can not get this polyline one too.
Civil3D 2020

RICVBA

  • Newt
  • Posts: 62
Re: Excel VBA to Select polyline and bring area back to excel
« Reply #14 on: April 18, 2014, 07:54:58 AM »
if you send me the dwg, I could have a look at it. but in Acad2010. maybe it comes out something useful for you anyhow.