Welcome,
Guest
. Please
login
or
register
.
1 Hour
1 Day
1 Week
1 Month
Forever
Login with username, password and session length
News:
Home
Help
Login
Register
TheSwamp
»
Code Red
»
AutoLISP (Vanilla / Visual)
»
Topic:
Remove extra Vertices from polyline
« previous
next »
Print
Pages: [
1
] |
Go Down
Author
Topic: Remove extra Vertices from polyline (Read 1025 times)
0 Members and 1 Guest are viewing this topic.
PM
Guest
Remove extra Vertices from polyline
«
on:
December 08, 2022, 08:11:14 AM »
Hi. I am using this code to delete extra vetrices from polyline. I want to ask two things
1) Is it possible to select more than one polyline a time ?
2) I have a drawing like the attach file with close polylines. I can not unerstand why some vertex not deleted. I want to keep only the vertex at the edges of each polygon not on sections with
other ? Is any way to update the code to delete extra verteces on staight "line"?
Code - Auto/Visual Lisp:
[Select]
(
defun
c:PSimple
(
/
doc ent elst vlst idx dir keep result hlst len
group_on
)
(
vl-load-com
)
;; CAB 11/03/07
;; group on the elements of a flat list
;; (group_on '(A B C D E F G) 3)
;; Result ((A B C) (D E F) (G nil nil)...)
(
defun
group_on
(
inplst gp#
/
outlst idx subLst
)
(
while
inplst
(
setq
idx
-
1
subLst
nil
)
(
while
(
<
(
setq
idx
(
1+
idx
)
)
gp#
)
(
setq
subLst
(
cons
(
nth
idx inplst
)
sublst
)
)
)
(
setq
outlst
(
cons
(
reverse
sublst
)
outlst
)
)
(
repeat
gp#
(
setq
inplst
(
cdr
inplst
)
)
)
)
(
reverse
outlst
)
)
(
setq
doc
(
vla-get-ActiveDocument
(
vlax-get-acad-object
)
)
)
(
vla-StartUndoMark
doc
)
(
setq
ent
(
car
(
entsel
"
\n
Επιλέξτε την polyline για διαγραφή των extra vertex: "
)
)
)
(
if
(
and
ent
(
setq
elst
(
entget
ent
)
)
(
equal
(
assoc
0
elst
)
'
(
0
.
"LWPOLYLINE"
)
)
)
(
progn
(
setq
idx
0
)
(
repeat
(
fix
(
vlax-curve-getendparam
ent
)
)
(
cond
(
(
null
keep
)
(
setq
keep '
(
1
)
dir
(
angle
'
(
0
0
)
(
vlax-curve-getFirstDeriv
ent
0.0
)
)
)
)
(
(
or
(
null
(
vlax-curve-getFirstDeriv
ent idx
)
)
(
equal
dir
(
setq
dir
(
angle
'
(
0
0
)
(
vlax-curve-getFirstDeriv
ent idx
)
)
)
0.000001
)
)
(
setq
keep
(
cons
0
keep
)
)
)
(
(
setq
keep
(
cons
1
keep
)
)
)
)
(
setq
idx
(
1+
idx
)
)
)
(
setq
vlst
(
vl
-
remove
-
if
-
not
'
(
lambda
(
x
)
(
vl-position
(
car
x
)
'
(
40
41
42
10
)
)
)
elst
)
)
(
setq
vlst
(
group_on vlst
4
)
)
(
setq
idx
-
1
len
(
1-
(
length
vlst
)
)
keep
(
reverse
(
cons
1
keep
)
)
)
(
while
(
<=
(
setq
idx
(
1+
idx
)
)
len
)
(
cond
(
(
not
(
zerop
(
cdr
(
cadddr
(
nth
idx vlst
)
)
)
)
)
; keep arcs
(
setq
result
(
cons
(
nth
idx vlst
)
result
)
)
)
(
(
not
(
zerop
(
nth
idx keep
)
)
)
(
setq
result
(
cons
(
nth
idx vlst
)
result
)
)
)
)
)
(
setq
hlst
(
vl
-
remove
-
if
'
(
lambda
(
x
)
(
vl-position
(
car
x
)
'
(
40
41
42
10
)
)
)
elst
)
)
(
mapcar
'
(
lambda
(
x
)
(
setq
hlst
(
append
hlst x
)
)
)
(
reverse
result
)
)
(
setq
hlst
(
subst
(
cons
90
(
length
result
)
)
(
assoc
90
hlst
)
hlst
)
)
(
entmod
hlst
)
)
)
(
vla-EndUndoMark
doc
)
(
princ
)
)
Thanks
Logged
ronjonp
Needs a day job
Posts: 7529
Re: Remove extra Vertices from polyline
«
Reply #1 on:
December 08, 2022, 09:36:30 AM »
Have you seen this?
http://www.theswamp.org/index.php?topic=19865.msg244892#msg244892
Logged
Windows 11 x64 - AutoCAD /C3D 2023
Custom Build PC
PM
Guest
Re: Remove extra Vertices from polyline
«
Reply #2 on:
December 08, 2022, 10:57:41 AM »
Thanks r
onjonp
. This code works fine !!!
Code - Auto/Visual Lisp:
[Select]
;; Purge-Pline (gile) 2007/11/25
;;
;; Removes all superfluous vertex (overwritten, colinear or concentric)
;; Keeps arcs and widths
;; Keeps aligne vertices which show a width break
;; Closes pline which start point and end point are overwritten
(
defun
purge
-
pline
(
pl
/
regular
-
width colinear concentric
del
-
cadr
pour
-
car
elst closed old
-
p old
-
b
old
-
sw old
-
ew new
-
d new
-
p new
-
b new
-
sw
new
-
ew b1 b2
)
;; Evaluates if the pline width is regular on 3 successive points
(
defun
regular
-
width
(
p1 p2 p3 ws1 we1 ws2 we2
/
delta
)
(
or
(
=
ws1 we1 ws2 we2
)
(
and
(
=
we1 ws2
)
(
/=
0
(
setq
delta
(
-
we2 ws1
)
)
)
(
equal
(
/
(
-
(
vlax-curve-getDistAtPoint
pl
(
trans
p2 pl
0
)
)
(
vlax-curve-getDistAtPoint
pl
(
trans
p1 pl
0
)
)
)
(
-
(
vlax-curve-getDistAtPoint
pl
(
trans
p3 pl
0
)
)
(
vlax-curve-getDistAtPoint
pl
(
trans
p1 pl
0
)
)
)
)
(
/
(
-
we1
(
-
we2 delta
)
)
delta
)
1e
-
9
)
)
)
)
;; Evaluates if 3 successive vertices are aligned
(
defun
colinear
(
p1 p2 p3 b1 b2
)
(
and
(
zerop
b1
)
(
zerop
b2
)
(
null
(
inters
p1 p2 p1 p3
)
)
)
)
;; Evaluates if 3 sucessive vertices have the same center
(
defun
concentric
(
p1 p2 p3 b1 b2
/
bd1 bd2
)
(
if
(
and
(
/=
0.0
b1
)
(
/=
0.0
b2
)
(
equal
(
caddr
(
setq
bd1
(
BulgeData b1 p1 p2
)
)
)
(
caddr
(
setq
bd2
(
BulgeData b2 p2 p3
)
)
)
1e
-
9
)
)
(
tan
(
/
(
+
(
car
bd1
)
(
car
bd2
)
)
4.0
)
)
)
)
;; Removes the second item of the list
(
defun
del
-
cadr
(
lst
)
(
set
lst
(
cons
(
car
(
eval
lst
)
)
(
cddr
(
eval
lst
)
)
)
)
)
;; Pours the first item of a list to another one
(
defun
pour
-
car
(
from to
)
(
set
to
(
cons
(
car
(
eval
from
)
)
(
eval
to
)
)
)
(
set
from
(
cdr
(
eval
from
)
)
)
)
(
setq
elst
(
entget
pl
)
)
(
and
(
=
1
(
logand
1
(
cdr
(
assoc
70
elst
)
)
)
)
(
setq
closed T
)
)
(
mapcar
(
function
(
lambda
(
x
)
(
cond
(
(
=
(
car
x
)
10
)
(
setq
old
-
p
(
cons
x old
-
p
)
)
)
(
(
=
(
car
x
)
40
)
(
setq
old
-
sw
(
cons
x old
-
sw
)
)
)
(
(
=
(
car
x
)
41
)
(
setq
old
-
ew
(
cons
x old
-
ew
)
)
)
(
(
=
(
car
x
)
42
)
(
setq
old
-
b
(
cons
x old
-
b
)
)
)
(
T
(
setq
new
-
d
(
cons
x new
-
d
)
)
)
)
)
)
elst
)
(
mapcar
(
function
(
lambda
(
l
)
(
set
l
(
reverse
(
eval
l
)
)
)
)
)
'
(
old
-
p old
-
sw old
-
ew old
-
b new
-
d
)
)
(
and
closed
(
setq
old
-
p
(
append
old
-
p
(
list
(
car
old
-
p
)
)
)
)
)
(
and
(
equal
(
cdar
old
-
p
)
(
cdr
(
last
old
-
p
)
)
1e
-
9
)
(
setq
closed T
new
-
d
(
subst
(
cons
70
(
Boole
7
(
cdr
(
assoc
70
new
-
d
)
)
1
)
)
(
assoc
70
new
-
d
)
new
-
d
)
)
)
(
while
(
cddr
old
-
p
)
(
if
(
regular
-
width
(
cdar
old
-
p
)
(
cdadr
old
-
p
)
(
cdaddr
old
-
p
)
(
cdar
old
-
sw
)
(
cdar
old
-
ew
)
(
cdadr
old
-
sw
)
(
cdadr
old
-
ew
)
)
(
cond
(
(
colinear
(
cdar
old
-
p
)
(
cdadr
old
-
p
)
(
cdaddr
old
-
p
)
(
cdar
old
-
b
)
(
cdadr
old
-
b
)
)
(
mapcar
'del
-
cadr
'
(
old
-
p old
-
sw old
-
ew old
-
b
)
)
)
(
(
setq
bu
(
concentric
(
cdar
old
-
p
)
(
cdadr
old
-
p
)
(
cdaddr
old
-
p
)
(
cdar
old
-
b
)
(
cdadr
old
-
b
)
)
)
(
setq
old
-
b
(
cons
(
cons
42
bu
)
(
cddr
old
-
b
)
)
)
(
mapcar
'del
-
cadr
'
(
old
-
p old
-
sw old
-
ew
)
)
)
(
T
(
mapcar
'pour
-
car
'
(
old
-
p old
-
sw old
-
ew old
-
b
)
'
(
new
-
p new
-
sw new
-
ew new
-
b
)
)
)
)
(
mapcar
'pour
-
car
'
(
old
-
p old
-
sw old
-
ew old
-
b
)
'
(
new
-
p new
-
sw new
-
ew new
-
b
)
)
)
)
(
if
closed
(
setq
new
-
p
(
reverse
(
cons
(
car
old
-
p
)
new
-
p
)
)
)
(
setq
new
-
p
(
append
(
reverse
new
-
p
)
old
-
p
)
)
)
(
mapcar
(
function
(
lambda
(
new old
)
(
set
new
(
append
(
reverse
(
eval
new
)
)
(
eval
old
)
)
)
)
)
'
(
new
-
sw new
-
ew new
-
b
)
'
(
old
-
sw old
-
ew old
-
b
)
)
(
if
(
and
closed
(
regular
-
width
(
cdr
(
last
new
-
p
)
)
(
cdar
new
-
p
)
(
cdadr
new
-
p
)
(
cdr
(
last
new
-
sw
)
)
(
cdr
(
last
new
-
ew
)
)
(
cdar
new
-
sw
)
(
cdar
new
-
ew
)
)
)
(
cond
(
(
colinear
(
cdr
(
last
new
-
p
)
)
(
cdar
new
-
p
)
(
cdadr
new
-
p
)
(
cdr
(
last
new
-
b
)
)
(
cdar
new
-
b
)
)
(
mapcar
(
function
(
lambda
(
l
)
(
set
l
(
cdr
(
eval
l
)
)
)
)
)
'
(
new
-
p new
-
sw new
-
ew new
-
b
)
)
)
(
(
setq
bu
(
concentric
(
cdr
(
last
new
-
p
)
)
(
cdar
new
-
p
)
(
cdadr
new
-
p
)
(
cdr
(
last
new
-
b
)
)
(
cdar
new
-
b
)
)
)
(
setq
new
-
b
(
cdr
(
reverse
(
cons
(
cons
42
bu
)
(
cdr
(
reverse
new
-
b
)
)
)
)
)
)
(
mapcar
(
function
(
lambda
(
l
)
(
set
l
(
cdr
(
eval
l
)
)
)
)
)
'
(
new
-
p new
-
sw new
-
ew
)
)
)
)
)
(
entmod
(
append
new
-
d
(
apply
'
append
(
apply
'
mapcar
(
cons
'
list
(
list
new
-
p new
-
sw new
-
ew new
-
b
)
)
)
)
)
)
)
;; BulgeData Retourne les donnees d'un polyarc (angle rayon centre)
(
defun
BulgeData
(
bu p1 p2
/
ang rad cen
)
(
setq
ang
(
*
2
(
atan
bu
)
)
rad
(
/
(
distance
p1 p2
)
(
*
2
(
sin
ang
)
)
)
cen
(
polar
p1
(
+
(
angle
p1 p2
)
(
-
(
/
pi
2
)
ang
)
)
rad
)
)
(
list
(
*
ang
2.0
)
rad cen
)
)
;; TAN Retourne la tangente de l'angle
(
defun
tan
(
ang
)
(
/
(
sin
ang
)
(
cos
ang
)
)
)
;; SPL Calling function
(
defun
c:spl
(
/
ss n pl
)
(
vl-load-com
)
(
or
*
acad
*
(
setq
*
acad
*
(
vlax-get-acad-object
)
)
)
(
or
*
acdoc
*
(
setq
*
acdoc
*
(
vla-get-ActiveDocument
*
acad
*
)
)
)
(
princ
"
\n
Select les polylines to be treated or <All>: "
)
(
or
(
setq
ss
(
ssget
'
(
(
0
.
"LWPOLYLINE"
)
)
)
)
(
setq
ss
(
ssget
"_X"
'
(
(
0
.
"LWPOLYLINE"
)
)
)
)
)
(
if
ss
(
progn
(
vla-StartUndoMark
*
acdoc
*
)
(
setq
n
-
1
)
(
while
(
setq
pl
(
ssname
ss
(
setq
n
(
1+
n
)
)
)
)
(
purge
-
pline pl
)
)
(
princ
(
strcat
"
\n
\t
"
(
itoa
n
)
" treated polyline(s)."
)
)
(
vla-EndUndoMark
*
acdoc
*
)
)
(
princ
"
\n
None selected polyline."
)
)
(
princ
)
)
(
princ
"
\n
Simp-Pline loaded, type SPL to launch the function."
)
(
princ
)
Logged
dgpuertas
Newt
Posts: 80
Re: Remove extra Vertices from polyline
«
Reply #3 on:
December 09, 2022, 07:49:17 AM »
another:
http://www.theswamp.org/index.php?topic=57443.15
for:
https://en.wikipedia.org/wiki/Ramer%E2%80%93Douglas%E2%80%93Peucker_algorithm
Logged
Crank
Water Moccasin
Posts: 1503
Re: Remove extra Vertices from polyline
«
Reply #4 on:
December 09, 2022, 01:13:54 PM »
Or use the OVERKILL command
.
Logged
Vault Professional 2023 + AEC Collection
jvillarreal
Bull Frog
Posts: 332
Re: Remove extra Vertices from polyline
«
Reply #5 on:
December 09, 2022, 05:45:16 PM »
Or WEEDFEATURES if you have Civil 3D
Logged
mhupp
Bull Frog
Posts: 250
Re: Remove extra Vertices from polyline
«
Reply #6 on:
December 09, 2022, 10:26:34 PM »
This is more a manual lisp to pick a vertex you want to delete.
https://forums.autodesk.com/t5/autocad-forum/vertex-removal-lisp/m-p/4486299/highlight/true#M33618
Logged
MSTG007
Gator
Posts: 2601
I can't remeber what I already asked! I need help!
Re: Remove extra Vertices from polyline
«
Reply #7 on:
December 12, 2022, 07:51:34 AM »
piggy back on mhupp,
Civil3D you can use the Delete Elevation Point within the Ribbon. or the command: _AeccDeleteFeaturePI
Works with Feature Lines, 3D Polylines, and Polylines.
Logged
Civil3D 2020
Print
Pages: [
1
] |
Go Up
« previous
next »
TheSwamp
»
Code Red
»
AutoLISP (Vanilla / Visual)
»
Topic:
Remove extra Vertices from polyline