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

[Steven P]

I haven't had chance to look through this fully, but it looks like you have a few loops in there - with more and more polylines it might star to really slow down.

 

Interesting problem to think about maybe tomorrow

[BIGAL]

Just throwing ideas around, take the base Pline, get vertices then search for objects withing a polygon shape say 8 sides, then compare points find a point within say the desired tolerance and move that point within the other pline. In dwg can see two plines at one location so like @Steven P need a loop to check more than 1 pline meeting at a point.

 

Then pick another base pline and repeat. No time for coding the next few days.

[mhupp]

Get you going on what StevenP and BigAL are talking about.

 

(defun _option1 (/ SS SSPTZ SSVER PL1 PL2 PTlst1 PTlst2)
  (princ "\nSelect Base Polyline: ")
  (setq SS (ssget "_+.:E:S" '((0 . "LWPOLYLINE"))) ;emulates entselect only allowing you to select one entity at a time.
        PL1 (ssname ss 0)
  )
  (princ "\nSelect Polyline to Check against: ")
  (setq SS (ssget "_+.:E:S" '((0 . "LWPOLYLINE")))
        PL2 (ssname ss 0)
  )
  (if (and PL1 PL2) ; if both polylines are selected build cords
    (setq PTLST1 (getcoords PL1)
          PTLST2 (getcoords PL2)
    )
    (progn ;else prompt the user and rerun the command.
      (prompt "\nyou need to Select two Polylines for this command")
      (_option1)
      (exit)
    )
  )
  (foreach PT PTLST1
    ;insert polyline block with "*" infront this will explode into a polyline
    ;add polylione to selection set SSVER
  )
  (foreach PT PTLST2
    ;add point to each vertex 
    ;add point to SSPTZ selection set
  )
  (foreach check SSVER
    ;use getcoords on Polyline and save as checkpts
    ;feed that into (ssget "_WP" checkpts '((0 . "POINT")))
    ;check if only 1 point is found 
    ;if yes delete polyline and point
    ;if no skip polyline
  )
  (if (> (sslength SSPTZ) 0) ;points left are outside fuzz distance between poly1 and poly2 vertex
    (foreach PT SSPTZ
      ;delete pt and grdraw X at location
    )
  )
  (if (> (sslength SSVER) 0) ;if any polylnes are left a point wasn't found inside it.
    (progn
      (setq f (sslength SSVER))
      (prompt (strcat "\n " f "Fertex(s) found on poly1 not matching Poly2")
    )
  )
  (princ "\nCheck Complete !!.")
  (princ)
)

 

Edited 4 hours ago by mhupp

[mhy3sx]

Hi  mhupp. Thanks for the code , but I use Zwcad and get this 

 

Error: undefined function - GETCOORDS

 

Thanks

[mhupp]

2 hours ago, mhy3sx said:

Hi  mhupp. Thanks for the code , but I use Zwcad and get this 

 

Error: undefined function - GETCOORDS

 

Thanks

 

That isn't complete code it's just a layout of what to do. You had a function in your original post that had that function. 

 

-edit

You can see this post to pull cords from an polyline without its own function

https://www.cadtutor.net/forum/topic/76319-add-block-onto-polyline-vertices/#findComment-603350

 

(setq PTLST1 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget PL1))))

 

Edited 1 hour ago by mhupp