Jump to content

Overkill with draworder, just lines and arc's


Aftertouch

Recommended Posts

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.
)

Link to comment
Share on other sites

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...