Help: Check and Adjust Polylines.

[mhy3sx]

Hi , I want to do some updates to this code because is not working as i expeted.

The option1 check the vertex between 2 polylines and visualised the vertex with not mach.

I want the option1 to work for more than 2 polylines. 

 

The option 2 adjust the base polyline with one more , but i want to adjust only the problematic vertex not all (some times move more than the problematic vertex). I was thinking to export a file with the problematic vertex and then adjust the problematic vertex from file with the base polyline. I want to adjust more than one polyline a time .

 

;Help from marko_ribar in older post
; https://www.cadtutor.net/forum/topic/95097-adjust-polyline-sides/

(defun c:pladj (/ *error* dch dcl msg des drv _option1 _option2)

; -----option1---------

(defun _option1 (/ ss pl1 pl2 pl:lst1 pl:lst2 unmatched1 unmatched2 pt1 pt2 x_size fuzz)
  ;; Define size of the "X" (length of each line segment)
  (setq x_size 1.0) ; Adjust this value to make the "X" larger or smaller
  (setq fuzz 1.0)   ; Acceptable distance to consider vertices "close"

  ;; Create selection set and ensure two polylines are selected
  (setq ss (ssadd))
  (while (not (= (sslength ss) 2))
    (princ "\nSelect base Polyline: ")
    (setq ss (ssget (list (cons 0 "LWPOLYLINE"))))
    (if (not (= (sslength ss) 2))
      (princ "\nSelect other polylines to check")
    )
  )


  ;; Get the two polylines
  (setq pl1 (ssname ss 0)
        pl2 (ssname ss 1)
        pl:lst1 (getcoords pl1)
        pl:lst2 (getcoords pl2)
        unmatched1 '()
        unmatched2 '()
  )

  ;; Collect unmatched vertices from pl1
  (foreach a pl:lst1
    (if (not (member a pl:lst2))
      (setq unmatched1 (cons a unmatched1))
    )
  )

  ;; Collect unmatched vertices from pl2
  (foreach a pl:lst2
    (if (not (member a pl:lst1))
      (setq unmatched2 (cons a unmatched2))
    )
  )

  ;; Compare all unmatched pairs and draw Xs if they are close
  (foreach pt1 unmatched1
    (foreach pt2 unmatched2
      (if (<= (distance pt1 pt2) fuzz)
        (progn
          ;; Draw X at pt1 (color 140)
          (grdraw
            (list (- (car pt1) x_size) (- (cadr pt1) x_size) 0.0)
            (list (+ (car pt1) x_size) (+ (cadr pt1) x_size) 0.0)
            140
            0
          )
          (grdraw
            (list (- (car pt1) x_size) (+ (cadr pt1) x_size) 0.0)
            (list (+ (car pt1) x_size) (- (cadr pt1) x_size) 0.0)
            140
            0
          )

          ;; Draw X at pt2 (color 10)
          (grdraw
            (list (- (car pt2) x_size) (- (cadr pt2) x_size) 0.0)
            (list (+ (car pt2) x_size) (+ (cadr pt2) x_size) 0.0)
            10
            0
          )
          (grdraw
            (list (- (car pt2) x_size) (+ (cadr pt2) x_size) 0.0)
            (list (+ (car pt2) x_size) (- (cadr pt2) x_size) 0.0)
            10
            0
          )
        )
      )
    )
  )

  (princ "\nThe check comlete !!.")
  (princ)
)

(defun getcoords (ent / lst1 lst2)
  (setq lst1 (vlax-safearray->list
               (vlax-variant-value
                 (vlax-get-property
                   (vlax-ename->vla-object ent)
                   "Coordinates"))))
  (setq lst2 '())
  (while lst1
    (setq lst2 (append lst2 (list (list (car lst1) (cadr lst1)))))
    (setq lst1 (cddr lst1))
  )
  lst2
)




; -----option2---------

 (defun _option2 ( / vertlst unique lwupd lw1 lw2 enx1 enx fuzz vl1 vl2 bl par )

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun vertlst ( lw / enx )
    (mapcar
      (function
        (lambda ( p )
          (append
            (mapcar (function +) (list 0.0 0.0) (trans p lw 0))
            (list (cdr (assoc 38 enx)))
          )
        )
      )
      (mapcar (function cdr)
        (vl-remove-if
          (function
            (lambda ( x )
              (/= (car x) 10)
            )
          )
          (setq enx (entget lw))
        )
      )
    )
  )

  (defun unique ( lst fuzz / a ll )
    (while (setq a (car lst))
      (if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr lst))
        (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr lst)))
        (setq ll (cons a ll) lst (cdr lst))
      )
    )
    (reverse ll)
  )

  (defun lwupd nil
    (setq enx (subst (cons 38 (caddar vl2)) (assoc 38 enx) enx))
    (setq enx (subst (cons 90 (length vl2)) (assoc 90 enx) enx))
    (setq enx
      (append
        (reverse
          (cdr
            (member (assoc 10 enx) (reverse enx))
          )
        )
        (mapcar
          (function
            (lambda ( p )
              (cons 10 (trans p 0 lw2))
            )
          )
          vl2
        )
        (list (assoc 210 enx))
      )
    )
    (entupd (cdr (assoc -1 (entmod enx))))
  )

  (if
    (and
      (setq lw1 (car (entsel "\nSelect Base LWPOLYLINE ...")))
      (= (cdr (assoc 0 (setq enx1 (entget lw1)))) "LWPOLYLINE")
      (vl-every (function (lambda ( x ) (= (cdr x) 0.0))) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) enx1))
      (setq lw2 (car (entsel "\nSelect LWPOLYLINE you want to adjust...")))
      (= (cdr (assoc 0 (setq enx (entget lw2)))) "LWPOLYLINE")
      (vl-every (function (lambda ( x ) (= (cdr x) 0.0))) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) enx))
      (princ "\nAnnotation (m) : ")
      (not (initget 6))
      (setq fuzz (cond ( (getdist) ) ( 1.0 )))
    )
    (progn
      (setq vl1 (vertlst lw1))
      (setq vl2 (vertlst lw2))
      (setq vl2 (unique vl2 (* fuzz 0.5)))
      (foreach v1 vl1
        (foreach v2 vl2
          (if (<= (distance v1 v2) fuzz)
            (setq vl2
              (mapcar
                (function
                  (lambda ( x )
                    (if (equal x v2 (* fuzz 1e-12)) v1 x)
                  )
                )
                vl2
              )
            )
          )
        )
      )
      (setq vl2 (unique vl2 (* fuzz 0.5)))
      (foreach v vl1
        (if
          (and
            (not (vl-position v vl2))
            (<= (distance v (vlax-curve-getclosestpointto lw2 v)) fuzz)
            (setq par (vlax-curve-getparamatpoint lw2 (vlax-curve-getclosestpointto lw2 v)))
          )
          (setq vl2
            (append
              (reverse
                (member (nth (fix par) vl2) (reverse vl2))
              )
              (list v)
              (member (nth (1+ (fix par)) vl2) vl2)
            )
          )
        )
      )
      ;|
      (mapcar
        (function
          (lambda ( a b c )
            (if (equal (distance a c) (+ (distance a b) (distance b c)) (* fuzz 5e-5))
              (setq bl (cons b bl))
            )
          )
        )
        vl2
        (append (cdr vl2) (list (car vl2)))
        (append (cddr vl2) (list (car vl2) (cadr vl2)))
      )
      (foreach b (unique bl (* fuzz 1e-12))
        (setq vl2 (vl-remove b vl2))
      )
      |;
      (setq vl2 (unique vl2 (* fuzz 0.5)))
      (foreach v vl1
        (lwupd)
        (if
          (and
            (not (vl-position v vl2))
            (vl-some
              (function
                (lambda ( x )
                  (<= (distance x v) fuzz)
                )
              )
              vl2
            )
            (vl-some
              (function
                (lambda ( a b )
                  (equal (distance a b) (+ (distance a v) (distance v b)) (* fuzz 1e-3))
                )
              )
              vl2
              (append (cdr vl2) (list (car vl2)))
            )
            (setq par (vlax-curve-getparamatpoint lw2 (vlax-curve-getclosestpointto lw2 v)))
          )
          (setq vl2
            (append
              (reverse
                (member (nth (fix par) vl2) (reverse vl2))
              )
              (list v)
              (member (nth (1+ (fix par)) vl2) vl2)
            )
          )
        )
      )
      (lwupd)
    )
  )
  (princ)
)



;-------------------------------DCL MENU------------------------------------------------------------------------------------
  
    (defun *error* (msg)
    (if (and (= 'int (type dch)) (< 0 dch))(unload_dialog dch))
    (if (= 'file (type des))(close des))
    (if (and (= 'str (type dcl)) (findfile dcl))(vl-file-delete dcl))
    (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
      (princ (strcat "\nError: " msg)))
    (princ)
  )
  
  (setvar "OSMODE" 13)
  (if (not (and (setq dcl (vl-filename-mktemp nil nil ".dcl"))(setq des (open dcl "w"))))
    (princ "\nUnable to open DCL for writing.")
       (foreach str
                '(
                  "ed : edit_box { alignment = left; width = 25; edit_width = 10; fixed_width = true;}"
                  ""
                  "pladj : dialog { spacer; key = \"dcl\";"
                  " : boxed_radio_column {label = \"Select \";"
                  "    : radio_button { height = 1.0; width = 25; is_tab_stop = true;"
                  "      key = \"radio_button01\"; label = \"1. Check Polylines\";"
                  "  }"
                  "    : radio_button { height = 1.0; width = 25; is_tab_stop = true;"
                  "      key = \"radio_button02\"; label = \"2. Adjust Polylines\";"
                  "  }"  
                   "    }"
                  "  ok_only;"
                  "}"
                 )
         (write-line str des)
       ) ;;; end foreach
  ) ;;; end if
  (if des (progn (close des)(gc)))

  (if (and (setq dch (load_dialog dcl)) (new_dialog "pladj" dch))
    (progn
	 (set_tile "dcl" "Adjust Polyline")
      (action_tile "radio_button01" "(setq sng 1)")
      (action_tile "radio_button02" "(setq sng 2)")
      (action_tile "accept" "(done_dialog 1)")
      (action_tile "cancel" "(done_dialog 0)")
      ;;; dialog return value
      (setq drv (start_dialog))
      ;;; once loaded , get rid of temp dcl file
      (if (and dcl (findfile dcl))(vl-file-delete (findfile dcl)))
      (cond
	((= drv  0))
	((= drv  1)
         (cond
           ((= sng 1)(_Option1))
           ((= sng 2)(_Option2))
         )
        )
       )
    )
  )
  (princ)
 
) 

 

 

Thanks

test.dwg