Aftertouch Posted January 18, 2018 Posted January 18, 2018 Hello all, I am looking for some 'simple' code, that deletes duplicate lines and arc, based on the draworder. I need the program to always keep the 'upper' line and delete the duplicate. The regular overkill doesnt do the trick, since the duplicates are on different layers. At this moment, i use the code below, but the prosessing takes very long, and im hoping to find a more 'simple' version of the code below. I hope anyone cna help me out on this one... (defun KGA_Block_DrawOrder (blkObj / sortArr sortTblObj) (if (and (= :vlax-true (vla-get-hasextensiondictionary blkObj)) (setq sortTblObj (KGA_Sys_Apply 'vla-item (list (KGA_Data_ObjectExtDictGet blkObj) "ACAD_SORTENTS"))) ) (progn (vla-getfulldraworder sortTblObj 'sortArr :vlax-false) (mapcar 'vlax-variant-value (vlax-safearray->list sortArr)) ; Last is the top of the draworder. ) ) ) (defun KGA_Conv_Pickset_To_ObjectList (ss / i ret) (if ss (repeat (setq i (sslength ss)) (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret)) ) ) ) (defun KGA_Data_ObjectExtDictGet (object) (if (= :vlax-true (vla-get-hasextensiondictionary object)) (vla-getextensiondictionary object) ) ) ; Make a zero based list of integers. ; With speed improvement based on Reini Urban's (std-%setnth). ; (KGA_List_IndexSeqMakeLength 7) => (0 1 2 3 4 5 6) (defun KGA_List_IndexSeqMakeLength (len / ret) (repeat (rem len 4) (setq ret (cons (setq len (1- len)) ret)) ) (repeat (/ len 4) (setq ret (vl-list* (- len 4) (- len 3) (- len 2) (- len 1) ret ) ) (setq len (- len 4)) ) ret ) (defun KGA_Sys_Apply (expr varLst / ret) (if (not (vl-catch-all-error-p (setq ret (vl-catch-all-apply expr varLst)))) ret ) ) (defun KGA_Sys_ObjectOwner (obj) (vla-objectidtoobject (vla-get-database obj) (vla-get-ownerid obj)) ) (defun BKG_OverkillEqual (ss seg fuzz / N_Equal_P N_EqualPoints_P N_PointList curveALst datLst delA_P idxLst n ordLst ptsLst ) (defun N_Equal_P (curveALst curveBLst) ; Format of lists: (staPt endPt objNme obj). (cond ( (and (equal (car curveALst) (car curveBLst) fuzz) ; Sta = Sta. (equal (cadr curveALst) (cadr curveBLst) fuzz) ; End = End. ) (if (= "AcDbLine" (caddr curveALst) (caddr curveBLst)) T (N_EqualPoints_P (cadddr curveALst) (cadddr curveBLst) nil) ) ) ( (and (equal (car curveALst) (cadr curveBLst) fuzz) ; Sta = End. (equal (cadr curveALst) (car curveBLst) fuzz) ; End = Sta. ) (if (= "AcDbLine" (caddr curveALst) (caddr curveBLst)) T (N_EqualPoints_P (cadddr curveALst) (cadddr curveBLst) T) ) ) ) ) (defun N_EqualPoints_P (objA objB revB_P / ptsA ptsB) (setq ptsA (cond ((cadr (assoc objA ptsLst))) ((N_PointList objA)))) (setq ptsB (cond ((cadr (assoc objB ptsLst))) ((N_PointList objB)))) (if revB_P (equal ptsA (reverse ptsB) fuzz) (equal ptsA ptsB fuzz) ) ) (defun N_PointList (obj / pts size) ; Output does not include start and end point. (setq size (/ (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) seg)) (setq pts (mapcar '(lambda (idx) (vlax-curve-getpointatdist obj (* idx size))) idxLst ) ) (setq ptsLst (cons (list obj pts) ptsLst)) pts ) (setq idxLst (cdr (KGA_List_IndexSeqMakeLength seg))) ; Used by N_PointList. ;; For "_X" and "_A" sets the last created object is the first in datLst. ;; This is the top of the draworder if ordLst is nil. (setq datLst (KGA_Conv_Pickset_To_ObjectList ss)) (setq ordLst (reverse (KGA_Block_DrawOrder (KGA_Sys_ObjectOwner (car datLst))))) ; First is the top of the draworder. (setq datLst (vl-remove nil (mapcar '(lambda (obj / onm) (if (and (vlax-write-enabled-p obj) (vl-position (setq onm (vla-get-objectname obj)) '("AcDb2dPolyline" "AcDbArc" "AcDbCircle" "AcDbEllipse" "AcDbLine" "AcDbPolyline" "AcDbSpline") ) ) (list (vlax-curve-getstartpoint obj) (vlax-curve-getendpoint obj) onm obj ) ) ) datLst ) ) ) (setq n 0) (while (cadr datLst) (setq delA_P nil) (setq curveALst (car datLst)) (foreach curveBLst (setq datLst (cdr datLst)) (if (N_Equal_P curveALst curveBLst) (if (or (not ordLst) (< (vl-position (cadddr curveALst) ordLst) (vl-position (cadddr curveBLst) ordLst)) ) (progn (setq datLst (vl-remove curveBLst datLst)) (vla-delete (cadddr curveBLst)) (setq n (1+ n)) ) (setq delA_P T) ; Don't delete curve A just yet. ) ) ) (if delA_P (progn (vla-delete (cadddr curveALst)) (setq n (1+ n)) ) ) ) n ; Return total deleted entities. ) Quote
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.