TheSwamp
Code Red => VB(A) => Topic started by: MSTG007 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.)?
-
Option Explicit
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
-
Way cool. Can I have the user select a bunch of polylines at once?
-
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.
-
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
-
try this one
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
-
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?
-
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)
-
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:
For Each LWPoly In ssetObj
Any help would be great! It did work in the previous cad version.
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
-
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
-
Thank you so much. I will see if I can get this to work tomorrow. I will let you know my results!
-
Well, I tried and I am still getting the same error in the same location... Weird. Do you see anything that is incorrect?
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
-
Does it compile ok?
-
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.
-
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.
-
Hi your code is very useful for me
can you please add inside text (co-ordinate if possible) export to excel with area - Please check attach sample drawing and excel
thanks for giving us very useful code
-
see
https://forums.autodesk.com/t5/visual-basic-customization/excel-vba-for-cad-polyline-select-and-bring-area-back-to-excel/m-p/9221745#M103418 (https://forums.autodesk.com/t5/visual-basic-customization/excel-vba-for-cad-polyline-select-and-bring-area-back-to-excel/m-p/9221745#M103418),
where you posted the same question