a little modification to do iterative aling segments with the same segment source, only works with pline
(defun c:Realign ( / *error* cmd e1 e2 ent1 ent2 etype p obj param p1 p2 p3 p4 p3a p4a ang)
(gc)
(vl-load-com)
;; Program realigns a line or straight polyline segment
;; with a source line or straight polyline segment.
(defun *error* (err)
(if (= (type cmd) 'INT)(setvar "cmdecho" cmd))
(vla-endundomark *doc*)
(cond
((not err))
((wcmatch (strcase err) "*CANCEL*,*QUIT*")
(vl-exit-with-error "\r ")
)
(1 (vl-exit-with-error (strcat "\r*ERROR*: " err)))
)
(princ)
)
;;-----------------------------------------------
;; Initialize some drawing and program variables:
;;
(setq *doc* (vlax-get (vlax-get-acad-object) 'Activedocument)
cmd (getvar "cmdecho")
)
(vla-endundomark *doc*)
(vla-startundomark *doc*)
(setvar "cmdecho" 0)
(command "_.expert" (getvar "expert")) ;; dummy command
(defun @Anonymous (p)(list (car p)(cadr p)))
;;--------------------------------------------------------------
;; Homemade function to substitute one point in a list of points
;; because the AutoLisp subst function fails if the input value doesn't exactly match
;; any item in the list. This substitutes by the position, not the value.
(defun @subst_nth (new pos items / part1 part2)
(setq part1 (reverse (cdr (member (nth pos items)(reverse items))))
part2 (cdr (member (nth pos items) items))
)
(append part1 (list new) part2)
)
;;------------------
;; Begin the action:
(and
(setq p (entsel "\nSelect source line segment: "))
(setq e1 (car p))
(setq ent1 (entget e1))
(setq etype (cdr (assoc 0 ent1)))
(cond
((= etype "LINE")
(setq p1 (cdr (assoc 10 ent1))
p2 (cdr (assoc 11 ent1))
)
)
((= etype "LWPOLYLINE")
(setq p (cadr p)
obj (vlax-ename->vla-object e1)
p (vlax-curve-getclosestpointto obj p)
param (vlax-curve-getparamatpoint obj p)
)
(if (not (zerop (vla-getbulge obj param)))
(prompt "\n Segment selected is bulged.")
(setq p1 (vlax-curve-getpointatparam obj (fix param))
p2 (vlax-curve-getpointatparam obj (1+ (fix param)))
)
)
)
(1 (prompt (strcat "\n Entity selected is a(n) " etype)))
)
(while (setq p(entsel "\nSelect line segment to realign to source: "))
(setq e2 (car p) p (cadr p))
(or (not (equal e1 e2))
(prompt "\n Same entity selected.")
)
(setq ent2 (entget e2)
etype (cdr (assoc 0 ent2))
obj (vlax-ename->vla-object e2)
)
(cond
((= etype "LINE")
(setq p3 (cdr (assoc 10 ent2))
p4 (cdr (assoc 11 ent2))
)
)
((= etype "LWPOLYLINE")
(setq p (vlax-curve-getclosestpointto e2 p)
param (vlax-curve-getparamatpoint e2 p)
p3 (vlax-curve-getpointatparam e2 (fix param))
p4 (vlax-curve-getpointatparam e2 (1+ (fix param)))
plist (vl-remove-if-not '(lambda (x)(= (car x) 10)) ent2)
ok 0
)
(or
(zerop (vla-getbulge obj param))
(prompt "\n Segment is bulged.")
)
)
(1 (prompt "\n Rntity selected is not a line or LWPolyline segment."))
)
(setq ok 1)
(setq ang (+ (angle p1 p2)(* pi 0.5)))
(setq ok 2)
(setq p3a (inters p3 (polar p3 ang 10) p1 p2 nil)
p4a (inters p4 (polar p4 ang 10) p1 p2 nil)
ok 3
)
(if (= etype "LINE")
(setq ent2 (subst (cons 10 p3a)(assoc 10 ent2) ent2)
ent2 (subst (cons 11 p4a)(assoc 11 ent2) ent2)
ok 4
)
(progn ;; For LWPolylines
;| This didn't work
(setq ent2 (subst (cons 10 (@2d p3a))(cons 10 p3) ent2)
ent2 (subst (cons 10 (@2d p4a))(cons 10 p4) ent2)
ok 5
)
|;
;| Neither did this
(vlax-invoke obj 'removevertex obj (fix param))
(vlax-invoke obj 'addvertex obj (fix param) p3a)
(vlax-invoke obj 'removevertex obj (1+ (fix param)))
(vlax-invoke obj 'addvertex obj (1+ (fix param)) p4a)
(setq ok 5)
|;
;| Subst isn't working here either
(print (mapcar 'cdr plist))
(setq plist (mapcar 'cdr plist)
plist (subst (@2d p3a) p3 plist)
plist (subst (@2d p4a) p4 plist)
)
(print plist)
(vlax-put obj 'coordinates (apply 'append plist))
(vla-update obj)
(setq ok 5)
|;
;; THIS DOES WORK!!
(setq plist (mapcar 'cdr plist)
plist (@subst_nth (@2d p3a) (fix param) plist)
plist (@subst_nth (@2d p4a) (1+ (fix param)) plist)
)
(print plist)
(vlax-put obj 'coordinates (apply 'append plist))
(vla-update obj)
(setq ok 5)
)
)
(setq ok 6))
;(print ent2)
;(entmod ent2)
;(setq ok 7)
;(entupd e2)
)
(*error* nil)
)
