Jump to content

Leaderboard

Popular Content

Showing content with the highest reputation on 09/28/2023 in all areas

  1. https://forums.augi.com/showthread.php?153671-SSget-X-except-Frozen-Locked-or-Off-layers And a little bit of editing: (defun c:demo (/ a ex) (setq ex nil) (while (setq a (tblnext "LAYER" (null a))) (if (and (or (> (cdr (assoc 70 a)) 0) (minusp (cdr (assoc 62 a))) ) (not (wcmatch (cdr (assoc 2 a)) "*|*")) ) (setq ex (cons (strcat "," (cdr (assoc 2 a))) ex)) ) ) (setq ss (ssget "_X" (append (list (cons 0 "LWPOLYLINE,POLYLINE") (cons 410 (getvar 'ctab)) ) (if ex (list '(-4 . "<NOT") (cons 8 (strcat (apply 'strcat ex))) '(-4 . "NOT>") ) '(8 . "*") ) ) ) ) (princ) )
    1 point
  2. @exceed Sorry for stealing your code, I just made quick fix, as OP wasn't satisfied... ; DentRepair - 2023.09.15 exceeds ; Dent repairs polyline segments with vertical and horizontal outlines outwards. ; If the length of one line segment is less than a certain value, it adjusted out to a wider side. (defun c:DentRepair ( / *error* LM:group<n LM:group<n-sub LM:SubstNth LM:Unique dtr rtd collinear-p lwpolybylist acdoc ss index ent obj clist cllen isclosed index2 p0 p1 p2 p3 linelength lineangle setlength tempclist1 tempclist2 temp1 temp2 temp1obj temp2obj temp1area temp2area stopper resultent clistx ps pe ) (vl-load-com) (defun *error* (msg) (if (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (vla-EndUndoMark acdoc) (princ) ) ;; Group by Number - Lee Mac ;; Groups a list 'l' into a list of lists, each of max length 'n' (defun LM:group<n ( l n ) (if l (LM:group<n-sub (cons nil l) n n)) ) (defun LM:group<n-sub ( l m n ) (if (and (cdr l) (< 0 n)) (LM:group<n-sub (cons (cons (cadr l) (car l)) (cddr l)) m (1- n)) (cons (reverse (car l)) (LM:group<n (cdr l) m)) ) ) ;;---------------------=={ Subst Nth }==----------------------;; ;; ;; ;; Substitutes an item at the nth position in a list. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; a - item to substitute ;; ;; n - position in list to make the substitution ;; ;; l - list in which to make the substitution ;; ;;------------------------------------------------------------;; ;; Returns: Resultant list following the substitution ;; ;;------------------------------------------------------------;; (defun LM:SubstNth ( a n l ) (if l (if (zerop n) (cons a (cdr l)) (cons (car l) (LM:SubstNth a (1- n) (cdr l))) ) ) ) ;; Unique - Lee Mac ;; Returns a list with duplicate elements removed. (defun LM:Unique ( l ) (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))) ) ; degree to radian (defun dtr (a) (setq x (* pi (/ a 180.0))) ) ; radian to degree (defun rtd (a) (setq x (/ (* a 180) pi)) ) (defun collinear-p ( p1 p p2 ) (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6) ) (defun lwpolybylist (lst cls) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls) ) (mapcar (function (lambda (p) (cons 10 p))) lst) ) ) ) (setq acdoc (vla-get-ActiveDocument (vlax-get-ACAD-Object))) (vla-StartUndoMark acdoc) (setq setlength (getreal "\n Input Minimum Segment Value (Space Bar = 1.5): ")) ; can edit this value (if (= setlength nil) (setq setlength 1.5) (setq setlength (abs setlength)) ) (setq ss (ssget '((0 . "LWPOLYLINE")))) (repeat (setq index (sslength ss)) (setq ent (ssname ss (setq index (1- index)))) (setq obj nil clist nil cllen nil isclosed nil resultent nil p1 nil p2 nil p0 nil p3 nil linelength nil lineangle nil tempclist1 nil tempclist2 nil temp1 nil temp2 nil temp1area nil temp2area nil temp1obj nil temp2obj nil) (setq obj (vlax-ename->vla-object ent)) (setq clist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq cllen (length clist)) (setq isclosed (vlax-get-property obj 'closed)) ;(princ "\n isclosed? ") ;(princ isclosed) (if (= isclosed :vlax-false) (progn (if (and (= (car clist) (nth (- cllen 2) clist)) (= (cadr clist) (nth (- cllen 1) clist))) (progn) (setq clist (append clist (list (car clist) (cadr clist)))) ) ) ) (setq clist (lm:unique (lm:group<n clist 2))) ;(princ "\n clist - ") ;(princ clist) (setq cllen (length clist)) (setq index2 0) (if (>= cllen 4) (progn (repeat cllen (if (and (/= index2 0) (/= resultent nil)) (entdel resultent) ) (setq p1 (nth index2 clist)) (if (= (- cllen 1) index2) (setq p2 (nth 0 clist)) (setq p2 (nth (+ index2 1) clist)) ) (if (= index2 0) (setq p0 (last clist)) (setq p0 (nth (- index2 1) clist)) ) (if (<= index2 (- cllen 3)) (setq p3 (nth (+ index2 2) clist)) (setq p3 (nth (- (+ index2 2) cllen) clist)) ) (setq linelength (distance p1 p2)) ;(princ "\n linelength - ") ;(princ linelength) (setq lineangle (rtd (angle p1 p2))) ;(princ "\n lineangle - ") ;(princ lineangle) (setq tempclist1 '()) (setq tempclist2 '()) (if (>= linelength setlength) (progn ;(if (or (= lineangle 0) (= lineangle 90) (= lineangle 180) (= lineangle 270) (= lineangle 360)) ; (progn) ; (progn) ;) ) (progn (cond ( (or (= (rtos lineangle 2 0) "0") (= (rtos lineangle 2 0) "180") (= (rtos lineangle 2 0) "360")) ;horizontal line (setq tempclist1 (LM:SubstNth (list (car p1) (cadr p0)) index2 clist)) (setq tempclist1 (LM:SubstNth (list (car p2) (cadr p0)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1)) (setq tempclist2 (LM:SubstNth (list (car p1) (cadr p3)) index2 clist)) (setq tempclist2 (LM:SubstNth (list (car p2) (cadr p3)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2)) ) ( (or (= (rtos lineangle 2 0) "90") (= (rtos lineangle 2 0) "270")) ;verical line (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p1)) index2 clist)) (setq tempclist1 (LM:SubstNth (list (car p0) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist1)) (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p1)) index2 clist)) (setq tempclist2 (LM:SubstNth (list (car p3) (cadr p2)) (if (= (- cllen 1) index) 0 (+ index2 1)) tempclist2)) ) ( t (setq tempclist1 clist) (setq tempclist2 clist) ) ) ;(princ "\n tempclist1 - ") ;(princ tempclist1) (setq temp1 (lwpolybylist tempclist1 1)) ;(princ "\n tempclist2 - ") ;(princ tempclist2) (setq temp2 (lwpolybylist tempclist2 1)) (setq temp1obj (vlax-ename->vla-object temp1)) (setq temp2obj (vlax-ename->vla-object temp2)) (setq temp1area (vla-get-area temp1obj)) (setq temp2area (vla-get-area temp2obj)) (if (>= temp1area temp2area) (setq clist tempclist1) (setq clist tempclist2) ) (entdel temp1) (entdel temp2) ) ) ;(setq stopper (getstring "\n continue ? : ")) ;(princ "\n index2 - ") ;(princ index2) ;(princ " / cllen - ") ;(princ cllen) (setq index2 (+ index2 1)) ) ) (progn (princ "\n not enough vertices. (less then 4)") ) ) ;(setq stopper (getstring "\n continue ? : ")) (setq clistx nil) (setq clist (LM:Unique clist)) (if (vl-some '(lambda ( a b ) (not (or (equal (angle a b) (* 0.0 pi) 1e-8) (equal (angle a b) (* 0.5 pi) 1e-8) (equal (angle a b) (* 1.0 pi) 1e-8) (equal (angle a b) (* 1.5 pi) 1e-8) (equal (angle a b) (* 2.0 pi) 1e-8)))) (append clist clist) (append (cdr clist) (list (car clist)) (cdr clist) (list (car clist)))) (progn (setq clistx (vl-remove (last clist) clist)) (if (vl-some '(lambda ( a b ) (not (or (equal (angle a b) (* 0.0 pi) 1e-8) (equal (angle a b) (* 0.5 pi) 1e-8) (equal (angle a b) (* 1.0 pi) 1e-8) (equal (angle a b) (* 1.5 pi) 1e-8) (equal (angle a b) (* 2.0 pi) 1e-8)))) (append clistx clistx) (append (cdr clistx) (list (car clistx)) (cdr clistx) (list (car clistx)))) (setq clistx (vl-remove (car clist) clist)) ) (setq pe (last clist)) (setq ps (car clist)) (cond ( (< (abs (- (car pe) (car ps))) setlength) (setq clist (LM:SubstNth (list (car (nth 1 clist)) (cadr (nth (1- (length clist)) clist))) 0 clist)) (setq clist (vl-remove (last clist) clist)) (setq clist (append clist (list (list (car ps) (cadr pe))))) ) ( (< (abs (- (cadr pe) (cadr ps))) setlength) (setq clist (LM:SubstNth (list (cadr (nth 1 clist)) (car (nth (1- (length clist)) clist))) 0 clist)) (setq clist (vl-remove (last clist) clist)) (setq clist (append clist (list (list (car pe) (cadr ps))))) ) ) (setq clistx clist) (if (or (< (abs (- (car pe) (car ps))) setlength) (< (abs (- (cadr pe) (cadr ps))) setlength)) (setq clistx (append (list (list (car (cadr clistx)) (cadr (last clistx)))) (cdr clistx))) ) ) (setq clistx clist) ) (setq clistx (vl-remove nil (apply 'append (mapcar '(lambda ( a b c ) (if (collinear-p a b c) (list nil) (list b))) (cons (last clistx) (reverse (cdr (reverse clistx)))) clistx (append (cdr clistx) (list (car clistx))))))) (if (vl-some '(lambda ( a b ) (not (or (equal (angle a b) (* 0.0 pi) 1e-8) (equal (angle a b) (* 0.5 pi) 1e-8) (equal (angle a b) (* 1.0 pi) 1e-8) (equal (angle a b) (* 1.5 pi) 1e-8) (equal (angle a b) (* 2.0 pi) 1e-8)))) (append clistx clistx) (append (cdr clistx) (list (car clistx)) (cdr clistx) (list (car clistx)))) (setq clistx (append (list (list (car (last clistx)) (cadr (car clistx)))) clistx)) ) (setq resultent (lwpolybylist (LM:Unique clistx) 1)) ) (vla-EndUndoMark acdoc) (princ) ) HTH. M.R.
    1 point
×
×
  • Create New...