DWG Cleanup - Zero Length Plines & Text

i'm working on some code that will remove lines / polylines with zero length from the dwg, as well as (m)text objects that are null.

The text piece has been handled. I'm having trouble getting the length of the polyline. After searching the ng and google, i'm still at square one.
My problem is figuring out how to iterate thru the coords collection.
Would someone please point me in the right direction?


thanks!


zero length deletion:

Code:

Private Sub delete_zero_length()
Dim mySS As AcadSelectionSet
Dim oEnt As AcadEntity
Dim grpCode(0 To 4) As Integer
Dim dataVal(0 To 4) As Variant
Dim intLineCtr As Integer
Dim oLayer As AcadLayer
Dim bIsLocked As Boolean
Dim FUZZ As Double
Dim dblPlineLength As Double
Dim dblTempDist As Double
Dim Coords As Variant
Dim i As Integer

FUZZ = 0.0001

' Build a selection set of group codes and values to filter for: Text or Mtext.
grpCode(0) = -4
dataVal(0) = "<OR"
grpCode(1) = 0
dataVal(1) = "LINE"
grpCode(2) = 0
dataVal(2) = "LWPOLYLINE"
grpCode(3) = 0
dataVal(3) = "POLYLINE"
grpCode(4) = -4
dataVal(4) = "OR>"

'build selection set of (m)text entities
'Set mySS = BuildSelectionSet("Select TEXT or MTEXT to switch:", grpCode, dataVal)
Set mySS = vbdPowerSet("$TEMP$")
mySS.Select acSelectionSetAll, , , grpCode, dataVal
'Me.Hide
'mySS.SelectOnScreen grpCode, dataVal

Dim PT1(1) As Variant
Dim PT2(1) As Variant

For Each oEnt In mySS
If TypeOf oEnt Is AcadLine Then
If oEnt.length < FUZZ Then
Set oLayer = ThisDrawing.Layers(oEnt.Layer)
'Debug.Print oLayer.Name
bIsLocked = oLayer.Lock
oLayer.Lock = False
oEnt.Delete
UpdateStatus "Deleting Zero Length P/Line found on: " & oLayer.Name
DoEvents
oLayer.Lock = bIsLocked
Set oLayer = Nothing
intLineCtr = intLineCtr + 1
End If
ElseIf TypeOf oEnt Is AcadPolyline Then
Coords = oEnt.Coordinates

For i = LBound(Coords) To UBound(Coords) Step 4

PT1(0) = Coords(i)
PT1(1) = Coords(i + 1)
PT2(0) = Coords(i + 2)
PT2(1) = Coords(i + 3)
dblTempDist = dblTempDist + getDistance(PT1, PT2)
Next
ElseIf TypeOf oEnt Is AcadLWPolyline Then
Coords = oEnt.Coordinates

For i = LBound(Coords) To UBound(Coords) Step 2

PT1(0) = Coords(i)
PT1(1) = Coords(i + 1)
PT2(0) = Coords(i + 2)
PT2(1) = Coords(i + 3)
dblTempDist = dblTempDist + getDistance(PT1, PT2)
Next

dblPlineLength = dblTempDist
If dblPlineLength = 0 And oEnt.Area = 0 Then

Set oLayer = ThisDrawing.Layers(oEnt.Layer)
'Debug.Print oLayer.Name
bIsLocked = oLayer.Lock
oLayer.Lock = False
'oEnt.Delete
oEnt.Color = acGreen
oLayer.Lock = bIsLocked
Set oLayer = Nothing
intLineCtr = intLineCtr + 1
End If
End If
Next

Me.lblDeletedLineCount.Caption = CStr(intLineCtr)
DoEvents


End Sub

text deletion:

Code:

Private Sub Delete_All_Empty_Text()
Dim mySS As AcadSelectionSet
Dim oEnt As AcadEntity
Dim grpCode(0 To 3) As Integer
Dim dataVal(0 To 3) As Variant
Dim intLineCtr As Integer
Dim oLayer As AcadLayer
Dim bIsLocked As Boolean

' Build a selection set of group codes and values to filter for: Text or Mtext.
grpCode(0) = -4
dataVal(0) = "<OR"
grpCode(1) = 0
dataVal(1) = "TEXT"
grpCode(2) = 0
dataVal(2) = "MTEXT"
grpCode(3) = -4
dataVal(3) = "OR>"

'build selection set of (m)text entities
'Set mySS = BuildSelectionSet("Select TEXT or MTEXT to switch:", grpCode, dataVal)
Set mySS = vbdPowerSet("$TEMP$")
mySS.Select acSelectionSetAll, , , grpCode, dataVal
For Each oEnt In mySS
If TypeOf oEnt Is AcadText Or TypeOf oEnt Is AcadMText Then
If Trim(oEnt.TextString) = vbNullString Then
Set oLayer = ThisDrawing.Layers(oEnt.Layer)
'Debug.Print oLayer.Name
bIsLocked = oLayer.Lock
oLayer.Lock = False
oEnt.Delete
UpdateStatus "Deleting text found on: " & oLayer.Name
DoEvents
oLayer.Lock = bIsLocked
Set oLayer = Nothing
intLineCtr = intLineCtr + 1
End If
End If
Next

Me.lblDeletedTextCount.Caption = CStr(intLineCtr)
DoEvents
End Sub

 

Hi,

With the Coords variable you could do something like for a LW Polyline. The
normal Polyline will require a change to allow for the Z dimension. Note
that you can also delete zero length lines/arcs/polylines with a scripted
Map query.

Dim dTolerance as Double
dTolerance = 0.000001
For i = lbound(Coords) to Ubound(Coords) -3 Step 2
If Abs(Coords(i + 2) - Coords(i)) > dTolerance Then Goto
PolylineHasLength
If Abs(Coords(i + 3) - Coords(i + 1)) > dTolerance Then Goto
PolylineHasLength
Next i
DeletePolyline
PolylineHasLength:

There is a chance this will leave a polyline behind if it consists of a set
of vertices all less than your tolerance apart.

--


Laurie Comerford
CADApps
www.cadapps.com.au

length from the dwg, as well as (m)text objects that are null.

the polyline. After searching the ng and google, i'm still at square one.

 

Thanks for the quick reply
I found a function to determine the length of a polyline here at the ng.
However, the delete method no longer works??

Code:

dblPlineLength = LenPoly(oEnt)
If dblPlineLength < FUZZ Then

Set oLayer = ThisDrawing.Layers(oEnt.Layer)
'Debug.Print oLayer.Name
bIsLocked = oLayer.Lock
oLayer.Lock = False
oEnt.Delete '<- this isn't working for plines now??
oLayer.Lock = bIsLocked
Set oLayer = Nothing

length of a polyline:

Code:

Function LenPoly(oPoly As AcadEntity) As Double
'Get length of 3dPolyline or LWPolyline
Dim objSel As AcadEntity
Dim strName As String
Dim varPt As Variant
Dim objNewPL As AcadEntity
Dim obj As AcadObject
Dim Dis As Double
Dim varPL As Variant
Dim objArc As AcadArc
Dim i As Integer

On Error Resume Next
'make a copy and explode
Set objNewPL = oPoly.Copy()
varPL = objNewPL.Explode

'loop exploded components and add lengths
For i = 0 To UBound(varPL)
Set obj = varPL(i)
'arcs use different property
If obj.ObjectName = "AcDbArc" Then
Set objArc = obj
Dis = Dis + objArc.ArcLength
Else
Dis = Dis + obj.Length
End If
obj.Delete
Next i
LenPoly = Dis
End Function

 

What makes you think the delete isn't working? If it's because you still
have a pline there when done, it's coming from the LenPoly function. There
is no need to make a copy to explode, as the explode method leaves the
original in place and adds the exploded entities......this function will add
a double for every polyline you have.

 

I'm obviously unclear about how the explode method works.
I was under the impression that the codes delete method would delete all objects in the array??

the '<- lines are my questions about what's happening

Set objNewPL = oPoly.Copy() '<-copy object
varPL = objNewPL.Explode '<-placed exploded objects in an array

'loop exploded components and add lengths
For i = 0 To UBound(varPL)
Set obj = varPL(i)
'arcs use different property
If obj.ObjectName = "AcDbArc" Then
Set objArc = obj
Dis = Dis + objArc.ArcLength
Else
Dis = Dis + obj.Length
End If
obj.Delete '<- delete object from array??
Next i
LenPoly = Dis

 

OK, You have the original Pline that is sent to the function.
Next it is copied. Now you have 2 identical plines.
Next the copied one is exploded. Now you have the 2 previous plines plus the
individual lines/arcs.
Now you cycle through the individual lines/arcs and delete them, this is OK.
Now you exit the function with the length returned...........whoops, why is
that second pline still there?
Because the explode method does not act like the explode command! The method
leaves the original intact and ADDS the individual parts. So, you see, the
copy of the pline never needs to happen, or at least it must be deleted.....

 

Shoot, hit the send key too soon......

Just remove the line that copies and change the next line to explode the
original pline and you'll be good to go.

 

"whoops, why is that second pline still there?
Because the explode method does not act like the explode command! The method leaves the original intact and ADDS the individual parts. So, you see, the copy of the pline never needs to happen, or at least it must be deleted....."

Thanks for sharing this Jeff. The NG is a wealth of good information.