Extracting a 'Tally of Line Lengths' into a Spreadsheet

[richardw72376]

I have a very, very, large topographic survey that has a layer containing burried water pipes and I need to add up the individual lines in order to get the total length of water pipes on the whole 16 acre site. The only trouble is that it is a very extensive drawing and there are 3854 entities on the water pipe layer!!!

I have tried to browse the internet for a routine that will do it and the first thing I found was a very useful vba under the training section of the Autodesk website that claims to tally up all the line entities on the selected layers and arranges them into a spreadsheet - very clever! .

It is nice that they list of code all be it in a jpeg format so you can't cut and paste it out, but I was wondering if somebody already had the fully typed up, tried and tested article ready to run with.

I know there are 'Quantity Survey' cad packages out there but this is a one-off need and will never needed to be done again.

[LLCOOLJMARION]

Try this. It worked for me.

 ; Append an object data field value to entities
(defun c:expr2od (/ odt odf expr ss odc i en val)
  (if (setq odt (getstring "\nEnter the object Data Table name: "))
	(if	(setq odf
		   (getstring "\nEnter the Object Data Field name to append: ")
	)
	  (if (setq expr (getstring "\nEnter the Expression to evaluate: " t))
	(if (setq ss (ssget))
	  (progn
		;; define the new object data field
		(setq odc
		   (list
			 "columns"
			 (list
			   ;; same name and description
			   (cons "colname" odf)
			   (cons "coldesc" odf)
			   '("coltype" . "character")
			   '("defaultval" . "")
			 )
		   )
		)
		;; add the new object data field to the table
		(if	(not (ade_odaddfield odt odc))
		  (princ "\nUnable to add new field to Object Data table")
		)
		;; append results of expression evaluation into od fields on entities
		(repeat (setq i (sslength ss))
		  (setq
		i   (1- i)
		en  (ssname ss i)
		val (ade_expreval en expr "string")
		  )
		  (if val
		(if (not (ade_odsetfield en odt odf 0 val))
		  (princ "\nUnable to update OD field on entity ")
		)
		(princ "\nUnable to evaluate Expression on entity ")
		  )
		  (princ ".")
		)
	  )
	  (princ "\nNo objects selected ")
	)
	(princ "\nNo Expression entered ")
	  )
	  (princ "\nNo Object Data Field name entered")
	)
	(princ "\nNo Object Data Table name entered")
  )
  (princ "\nDone")
  (princ)
) ; c:expr2od

[ Moderator Action = ON ] What are [ CODE ] tags... [ Moderator Action = OFF ]

[mjfarrell]

When you say topographic survey, are you using Land Desktop?
Is so, conduct a query with MAP and set it to use the report function
and MAP will do it for you.

[jimoshea]

I use polylines with widths related to pipe diameters for my designs. Here's some code to extract that information and place a text string with the total lengths in the drawing.
I then use another app to extract the appriate text from the drawing and put it into Excel.

===== code =====
Public Sub get_all_polys()
On Error GoTo Err_Handler

'Dim pt1(0) As Double
'Dim pt2(0) As Double
Dim pnt2 As Variant
Dim FilterSet As Object
Dim grpCode(0) As Integer
Dim grpValue(0) As Variant
Dim ssAllPolys As AcadSelectionSet
Dim utilObj As AcadUtility
Dim ThePrompt As String
Dim strCurLayer As String

Set utilObj = ThisDrawing.Utility

strCurLayer = ThisDrawing.ActiveLayer.Name

'see if a selectionset named "all_polys" exists.
'if so, delete it so you can create a new one.
For Each ssAllPolys In ThisDrawing.SelectionSets
If ssAllPolys.Name = "all_polys" Then
ThisDrawing.SelectionSets.Item("all_polys").Delete
Exit For
End If
Next ssAllPolys

Set FilterSet = ThisDrawing.SelectionSets.Add("all_polys")
grpCode(0) = 0
grpValue(0) = "LWPOLYLINE"

FilterSet.SelectOnScreen grpCode, grpValue
'FilterSet.Select acSelectionSetAll, pt1, pt2, grpCode, grpValue

For Each FilterEnt In FilterSet
If FilterEnt.ConstantWidth > 0 Then
Select Case FilterEnt.ConstantWidth
Case 0.33, 0.333, 0.3333 '4" pipe
Dim intPline4 As Integer
varExplode
intPline4 = intPline4 + dblTemp
Case 0.5 '6" pipe
Dim intPline6 As Integer
varExplode
intPline6 = intPline6 + dblTemp
Case 0.67, 0.667, 0.6667 '8" pipe
Dim intPline8 As Integer
varExplode
intPline8 = intPline8 + dblTemp
Case 0.83, 0.833, 0.8333 '10" pipe
Dim intPline10 As Integer
varExplode
intPline10 = intPline10 + dblTemp
Case 1 '12" pipe
Dim intPline12 As Integer
varExplode
intPline12 = intPline12 + dblTemp
Case 1.3, 1.33, 1.333, 1.3333 '16" pipe
Dim intPline16 As Integer
varExplode
intPline16 = intPline16 + dblTemp
Case 2 '24" pipe
Dim intPline24 As Integer
varExplode
intPline24 = intPline24 + dblTemp
Case Else
MsgBox " ** HEY ** " & vbCrLf & _
"There is a polyline " & vbCrLf & _
"with a width of " & FilterEnt.ConstantWidth & vbCrLf & _
"not included in this list.", , "EXTRA POLYLINE?"
End Select
End If
Next_FilterEnt:
Next FilterEnt

ThePrompt = vbCrLf & "Text Location: "
pnt2 = utilObj.GetPoint(, ThePrompt)

ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("noplot")

If ThisDrawing.ActiveSpace = acModelSpace Then
If intPline4 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline4 & "-4"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline4 & "-4"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
If intPline6 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline6 & "-6"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline6 & "-6"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
If intPline8 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline8 & "-8"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline8 & "-8"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
If intPline10 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline10 & "-10"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline10 & "-10"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
If intPline12 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline12 & "-12"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline12 & "-12"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
If intPline16 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline16 & "-16"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline16 & "-16"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
If intPline24 > 0 Then
ThisDrawing.ModelSpace.AddText _
intPline24 & "-24"" 1101", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
ThisDrawing.ModelSpace.AddText _
intPline24 & "-24"" Pipe", pnt2, 0.5
pnt2(1) = pnt2(1) - (CDbl(1) * 1.2)
End If
Else
MsgBox "This app not valid in a layout.", vbCritical
End If

MsgBox "The 1101 value should be correct." & vbCrLf & _
"The 'Pipe' value needs to be changed!", _
vbCritical, "Check Values"

Exit_Here:

're-set previous layer back to current layer
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(strCurLayer)

Set utilObj = Nothing

Set FilterSet = Nothing

Exit Sub

Err_Handler:

Select Case Err.Number

Case -2147352567
If GetAsyncKeyState(VK_ESCAPE) Then
Err.Clear
Resume Exit_Here
End If

Case Else
MsgBox "Something caused the following error," _
& vbCrLf & "#" & Err.Number _
& vbCrLf & Err.Description, vbCritical, "*** ERROR ***"

End Select

Resume Exit_Here

End Sub

Public Function varExplode()
Dim varExploded As Variant
Dim intCnt As Integer

dblTemp = 0
varExploded = FilterEnt.Explode
'When you explode in VBA, you get an array of the sub entities****
For intCnt = LBound(varExploded) To UBound(varExploded)
If TypeOf varExploded(intCnt) Is AcadLine Then
dblTemp = dblTemp + varExploded(intCnt).Length
'That you can delete! *****
varExploded(intCnt).Delete
ElseIf TypeOf varExploded(intCnt) Is AcadArc Then
dblTemp = dblTemp + varExploded(intCnt).ArcLength
varExploded(intCnt).Delete
End If
Next intCnt

End Function
===== end code =====