get length of polyline/line in vba

I am a newcomer to vba and would like to know if anyone has some code which will prompt a user to select an object on screen ie. line/polyline and then save the length of the object so that i can beplaced in ablock as an atrribute. I have got the block part ok i am not sure of the get length and saving as attribute.
Help much appreciated

 

John,

Here is a function I just wrote that returns the length of a polyline. Hope
this helps.

Joe
--
Option Explicit

Public Function LengthOfPolyline() As Double
Dim Entity As AcadEntity
Dim Point As Variant
Dim Pline As AcadLWPolyline
Dim ExplodedObjects As Variant
Dim oRegion As Variant
Dim Index As Long

'handle errors inline
On Error Resume Next

ThisDrawing.Utility.GetEntity Entity, Point, "Select polyline"
'nothing was selected
If Entity Is Nothing Then Exit Function

If Entity.ObjectName <> "AcDbPolyline" Then Exit Function

If TypeOf Entity Is AcadLWPolyline Then
'cast Entity to Polyline proper
Set Pline = Entity
'explode polyline to get array of individual entities
ExplodedObjects = Pline.Explode

oRegion = ThisDrawing.ModelSpace.AddRegion(ExplodedObjects)
End If

'return the length of the polyline
LengthOfPolyline = oRegion(0).Perimeter

'clean up the screen
For Index = 0 To UBound(ExplodedObjects)
Set Entity = ExplodedObjects(Index)
Entity.Delete
Next Index

'delete the region object
Set Entity = oRegion(0)
Entity.Delete
End Function

Public Sub Test()
MsgBox "Length of Polyline is " & LengthOfPolyline, vbOKOnly, "Polyline
length"
End Sub

which will prompt a user to select an object on screen ie. line/polyline and
then save the length of the object so that i can beplaced in ablock as an
atrribute. I have got the block part ok i am not sure of the get length and
saving as attribute.

 

I thought I should mention that in A2k4 Polylines and LWPolylines have a
Length property. Joes code is still valid for prior releases.


--
R. Robert Bell, MCSE
www.AcadX.com


| John,
|
| Here is a function I just wrote that returns the length of a polyline.
Hope
| this helps.
|
| Joe
| --
| Option Explicit
|
| Public Function LengthOfPolyline() As Double
| Dim Entity As AcadEntity
| Dim Point As Variant
| Dim Pline As AcadLWPolyline
| Dim ExplodedObjects As Variant
| Dim oRegion As Variant
| Dim Index As Long
|
| 'handle errors inline
| On Error Resume Next
|
| ThisDrawing.Utility.GetEntity Entity, Point, "Select polyline"
| 'nothing was selected
| If Entity Is Nothing Then Exit Function
|
| If Entity.ObjectName <> "AcDbPolyline" Then Exit Function
|
| If TypeOf Entity Is AcadLWPolyline Then
| 'cast Entity to Polyline proper
| Set Pline = Entity
| 'explode polyline to get array of individual entities
| ExplodedObjects = Pline.Explode
|
| oRegion = ThisDrawing.ModelSpace.AddRegion(ExplodedObjects)
| End If
|
| 'return the length of the polyline
| LengthOfPolyline = oRegion(0).Perimeter
|
| 'clean up the screen
| For Index = 0 To UBound(ExplodedObjects)
| Set Entity = ExplodedObjects(Index)
| Entity.Delete
| Next Index
|
| 'delete the region object
| Set Entity = oRegion(0)
| Entity.Delete
| End Function
|
| Public Sub Test()
| MsgBox "Length of Polyline is " & LengthOfPolyline, vbOKOnly, "Polyline
| length"
| End Sub
|
|
| | > I am a newcomer to vba and would like to know if anyone has some code
| which will prompt a user to select an object on screen ie. line/polyline
and
| then save the length of the object so that i can beplaced in ablock as an
| atrribute. I have got the block part ok i am not sure of the get length
and
| saving as attribute.
| > Help much appreciated
|
|

 

OK Robert is a version that works for both. Be sure to add a reference to
the Microsoft Visual Basic Extensibility 5.3 library.

Joe
--
Public Function LengthOfPolyline() As Double
Dim Entity As AcadEntity
Dim Point As Variant
Dim Pline As AcadLWPolyline
Dim ExplodedObjects As Variant
Dim oRegion As Variant
Dim Index As Long

'handle errors inline
On Error Resume Next

ThisDrawing.Utility.GetEntity Entity, Point, "Select polyline"
'nothing was selected
If Entity Is Nothing Then Exit Function

If Entity.ObjectName <> "AcDbPolyline" Then Exit Function

If TypeOf Entity Is AcadLWPolyline Then
'cast Entity to Polyline proper
Set Pline = Entity

'determine if using 2004 or previous version
If Not IsReferenceMarked("C:\Program Files\Common Files\Autodesk
Shared\acax16enu.tlb") Then
'explode polyline to get array of individual entities
ExplodedObjects = Pline.Explode

oRegion = ThisDrawing.ModelSpace.AddRegion(ExplodedObjects)

Else
LengthOfPolyline = Pline.Length
Exit Function
End If
End If

'return the length of the polyline
LengthOfPolyline = oRegion(0).Perimeter

'clean up the screen
For Index = 0 To UBound(ExplodedObjects)
Set Entity = ExplodedObjects(Index)
Entity.Delete
Next Index

'delete the region object
Set Entity = oRegion(0)
Entity.Delete
End Function

Public Function IsReferenceMarked(Reference As String) As Boolean
Dim objIDE As VBIDE.VBE
Dim References() As String
Dim intI As Integer

Set objIDE = Application.VBE

ReDim References(1 To objIDE.ActiveVBProject.References.Count, 1)

For intI = 1 To objIDE.ActiveVBProject.References.Count
References(intI, 0) =
objIDE.ActiveVBProject.References.Item(intI).FullPath
If References(intI, 0) = Reference Then
IsReferenceMarked = True
Exit Function
End If
Next intI
End Function

Public Sub Test()
MsgBox "Length of Polyline is " & LengthOfPolyline, vbOKOnly, "Polyline
length"
End Sub

 

How can you say this gets the length of a polyline?

It only works if the polyline is closed and not
self-intersecting.

 

thanks guys but you are scaring me. how can i save the length to an attribute in a block. my idea is for a user to be prompted to select a line or polyline on screen and then after it is selected the length should be saved so that it can be passed to a sub for creating ablock with an attribute being the length. i expect to use this at least 100 times per drawing to eventually create a bom of at least 6 components per line/polyline.
thanks

 

The (LW)Polyline has a Length property in A2k4. Are you on A2k4? Just use
that.

If not, you can search for many pre-A2k4 solutions in this ng.


--
R. Robert Bell, MCSE
www.AcadX.com


| thanks guys but you are scaring me. how can i save the length to an
attribute in a block. my idea is for a user to be prompted to select a line
or polyline on screen and then after it is selected the length should be
saved so that it can be passed to a sub for creating ablock with an
attribute being the length. i expect to use this at least 100 times per
drawing to eventually create a bom of at least 6 components per
line/polyline.
| thanks

 

no at present i am using 2002. the following is my code so far.
the objects selected on screen will either be polyline or lines and total length is required


Option Explicit


Sub CreatingTendonId()
' Define the block
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
Set blockObj = ThisDrawing.Blocks.Add _
(insertionPnt, "cable")

' Add a circle to the block
Dim circleObj As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 1: center(1) = 1: center(2) = 1
radius = 320
Set circleObj = blockObj.AddCircle(center, radius)
circleObj.color = acYellow

' Add attributes to the block
Dim attributeObj As AcadAttribute
Dim getlength As Double
Dim height As Double
Dim mode As Long
Dim prompt As String
Dim insertionPoint(0 To 2) As Double
Dim tag As String
Dim value As String
height = 250
mode = acAttributeModeVerify
prompt = "tendon-id"
insertionPoint(0) = 1
insertionPoint(1) = 1
insertionPoint(2) = 0
tag = "ID"
value = "20"
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
attributeObj.color = acYellow
attributeObj.Alignment = acAlignmentMiddleCenter
height = 250
mode = acAttributeModeVerify
prompt = "No-Strands"
insertionPoint(0) = -56
insertionPoint(1) = -690
insertionPoint(2) = 0
tag = "strands"
value = "5s" 'will come from list box eventually
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
attributeObj.Rotation = 1.571
attributeObj.color = acYellow
height = 250
mode = acAttributeModeInvisible
prompt = "Anchor Block"
insertionPoint(0) = 5
insertionPoint(1) = 5
insertionPoint(2) = 0
tag = "anchor"
value = "AB405" 'will come from list box eventually
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
height = 250
mode = acAttributeModeInvisible
prompt = "Coupler"
insertionPoint(0) = 25
insertionPoint(1) = 25
insertionPoint(2) = 0
tag = "coupler"
value = "CB405" 'will come from list box eventually
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
height = 250
mode = acAttributeModeInvisible
prompt = "Dead (swage/onion)"
insertionPoint(0) = 5
insertionPoint(1) = 5
insertionPoint(2) = 0
tag = "dead"
value = "ONION" 'will come from list box eventually
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
height = 250
mode = acAttributeModeInvisible
prompt = "Pocket (No off)"
insertionPoint(0) = 5
insertionPoint(1) = 5
insertionPoint(2) = 0
tag = "pocket"
value = "2" 'will come from list box eventually
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
height = 250
mode = acAttributeModeInvisible
prompt = "tendon Length"
insertionPoint(0) = 5
insertionPoint(1) = 5
insertionPoint(2) = 0
tag = "length"
value = length 'this is where i wish to
'have the length placed in the block
Set attributeObj = blockObj.AddAttribute(height, mode, _
prompt, insertionPoint, tag, value)
End Sub
Sub InsertTendonIdBlock()
' Insert the block, creating a block reference
' and an attribute reference
Dim blockRefObj As AcadBlockReference
Dim inspt As Variant
inspt = ThisDrawing.Utility.GetPoint(, "select insertion point: ")
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(inspt, "cable", 1#, 1#, 1#, 0)
' ' Get the attributes for the block reference
' Dim varAttributes As Variant
' varAttributes = blockRefObj.GetAttributes
'
' ' Move the attribute tags and values into a
' ' string to be displayed in a Msgbox
' Dim strAttributes As String
' strAttributes = ""
' Dim I As Integer
' For I = LBound(varAttributes) To UBound(varAttributes)
' strAttributes = strAttributes + " Tag: " + _
' varAttributes(I).TagString + vbCrLf + _
' " Value: " + varAttributes(I).TextString
' Next
' MsgBox "The attributes for blockReference " + _
' blockRefObj.Name & " are: " & vbCrLf _
' & strAttributes


End Sub

 

Replace the previous LengthOfPolyline function with this one.

Joe
--
Public Function LengthOfPolyline() As Double
Dim Entity As AcadEntity
Dim Point As Variant
Dim Pline As AcadLWPolyline
Dim ExplodedObjects As Variant
Dim PLineLength As Double
Dim Index As Long
Dim oLine As AcadLine
Dim oArc As AcadArc

'handle errors inline
On Error Resume Next

ThisDrawing.Utility.GetEntity Entity, Point, "Select polyline"
'nothing was selected
If Entity Is Nothing Then Exit Function

If Entity.ObjectName <> "AcDbPolyline" Then Exit Function

If TypeOf Entity Is AcadLWPolyline Then
'cast Entity to Polyline proper
Set Pline = Entity

'determine if using 2004 or previous version
If Not IsReferenceMarked("C:\Program Files\Common Files\Autodesk
Shared\acax16enu.tlb") Then
'explode polyline to get array of individual entities
ExplodedObjects = Pline.Explode

For Index = 0 To UBound(ExplodedObjects)
Set Entity = ExplodedObjects(Index)
If TypeOf Entity Is AcadLine Then
Set oLine = Entity
PLineLength = PLineLength + oLine.Length
End If

If TypeOf Entity Is AcadArc Then
Set oArc = Entity
PLineLength = PLineLength + oArc.ArcLength
End If
Next Index

Else
LengthOfPolyline = PLineLength
Exit Function
End If
End If

'return the length of the polyline
LengthOfPolyline = PLineLength

'clean up the screen
For Index = 0 To UBound(ExplodedObjects)
Set Entity = ExplodedObjects(Index)
Entity.Delete
Next Index
End Function

 

Actually, scrub the whole previous post. Here is how you can do it in any
version. Granted there is a Length property exposed for Pline's in 2004 but
this routine does not have to deal with the version issue when using it in a
version post 2002.

Joe
--

Option Explicit

Public Function LengthOfPolyline() As Double
Dim Entity As AcadEntity
Dim Point As Variant
Dim Pline As AcadLWPolyline
Dim ExplodedObjects As Variant
Dim PLineLength As Double
Dim Index As Long
Dim oLine As AcadLine
Dim oArc As AcadArc

'handle errors inline
On Error Resume Next

ThisDrawing.Utility.GetEntity Entity, Point, "Select polyline"
'nothing was selected
If Entity Is Nothing Then Exit Function

If Entity.ObjectName <> "AcDbPolyline" Then Exit Function

If TypeOf Entity Is AcadLWPolyline Then
'cast Entity to Polyline proper
Set Pline = Entity

'explode polyline to get array of individual entities
ExplodedObjects = Pline.Explode

For Index = 0 To UBound(ExplodedObjects)
Set Entity = ExplodedObjects(Index)
If TypeOf Entity Is AcadLine Then
Set oLine = Entity
PLineLength = PLineLength + oLine.Length
End If

If TypeOf Entity Is AcadArc Then
Set oArc = Entity
PLineLength = PLineLength + oArc.ArcLength
End If
Next Index
End If

'return the length of the polyline
LengthOfPolyline = PLineLength

'clean up the screen
For Index = 0 To UBound(ExplodedObjects)
Set Entity = ExplodedObjects(Index)
Entity.Delete
Next Index
End Function

Public Sub Test()
MsgBox "Length of Polyline is " & LengthOfPolyline, vbOKOnly, "Polyline
length"
End Sub

 

This should do the job. It will also calculate the projected distance of a
3d poly
Just add some error checking and you should be fine.
I'll leave the testing to you.


Private Function Plen(pl As AcadObject) As Double
Dim Coors As Variant
Dim Dx As Double
Dim Dy As Double
Dim Tv As Long
Dim Bg() As Double
Dim j As Long
Dim Larc As Double
Dim Radio As Double
Dim AngI As Double
Dim AngD As Double
Dim Cuerda As Double
Dim st As Integer
Dim p3d As Boolean

p3d = False

If TypeOf pl Is AcadLWPolyline Then
st = 2
ElseIf TypeOf pl Is AcadPolyline Then
st = 3
ElseIf TypeOf pl Is Acad3DPolyline Then
st = 3: p3d = True
Else
Plen = 0
Exit Function
End If

Coors = pl.Coordinates
Tv = (UBound(Coors) + 1) / st
ReDim Bg(Tv - 1)
For i = 0 To Tv - 1
If p3d Then Bg(i) = 0 Else Bg(i) = pl.GetBulge(i)
Next i
j = 0

For i = 0 To UBound(Coors) - st Step st
Dx = Coors(i + st) - Coors(i)
Dy = Coors(i + st + 1) - Coors(i + 1)
Cuerda = Sqr(Dx * Dx + Dy * Dy)
If Bg(j) <> 0 Then
AngI = 4# * Atn(Abs(Bg(j)))
AngD = (AngI / 2#) - ((Atn(1#) * 4#) / 2#)
Radio = (Cuerda / 2#) / (Cos(AngD))
Larc = AngI * Radio
Plen = Plen + Larc
Else
Plen = Plen + Cuerda
End If
j = j + 1
Next i


End Function

--
Saludos, Ing. Jorge Jimenez, SICAD S.A., Costa Rica

which will prompt a user to select an object on screen ie. line/polyline and
then save the length of the object so that i can beplaced in ablock as an
atrribute. I have got the block part ok i am not sure of the get length and
saving as attribute.

 

If you don't mind command line propmts here's a shorter approach that works on almost any kind of cuves even on circles.

Public Function LengthOfCurve() As Double
Dim Entity As AcadEntity
Dim Point As Variant
Dim str As String
Dim per As Long

'handle errors inline
On Error Resume Next

ThisDrawing.Utility.GetEntity Entity, Point, "Select curve"

'nothing was selected
If Entity Is Nothing Then Exit Function

' create a lisp string
str = "(handent " & Chr(34) & Entity.Handle & Chr(34) & ")" & vbCr

ThisDrawing.SendCommand "_Area" & vbCr & "_O" & vbCr & str

' lengths are saved in Perimeter var
per = ThisDrawing.GetVariable("PERIMETER")

' returning
LengthOfCurve = per

End Function

Arcadio.