Delete trash from the drawing

March 11, 2020

Hello all.

Any idea to increase the speed of the code below?

Variant I is faster than Variant II.

(DEFUN C:DELPO (/ *error* ACDC FUZ IDX_LA IDX_PC IDX_PL IDX_TX LAY LAYS LSC SEL)
;; (setq CDA (getvar "CDATE")) ;;For tests

 (defun *error* (s)
  (or (wcmatch (strcase s) "*BREAK,*CANCEL*,*EXIT*") (prompt (strcat "\nError: " s)))
  (princ)
 ) ;;*error*

 (setq  ACDC  (vla-get-activedocument (vlax-get-acad-object))
     FUZ   1E-7
     IDX_LA  0.
     IDX_PC  0.
     IDX_PL  0.
     IDX_TX  0.
     LAYS  (vla-get-layers ACDC)
 )
       ;;;;;;;;;;;;;;;;;;;;;
       ;;                 ;;
       ;;    VERSION I    ;;
       ;;                 ;;
       ;;;;;;;;;;;;;;;;;;;;;
;;Points, exclude those on layers frozen, off and lock
 (ssget "_X" (quote ((0 . "POINT"))))
 (setq SEL (vla-get-activeselectionset ACDC))
 (if (> (vla-get-count SEL) 0)
  (vlax-for Obj SEL
   (setq LAY (vla-item LAYS (vla-get-layer Obj)))
   (if (equal (list (vla-get-freeze LAY) (vla-get-layeron LAY) (vla-get-lock LAY))
              (quote (:VLAX-FALSE :VLAX-TRUE :VLAX-FALSE))
       )
    (progn
     (vla-delete Obj)
     (setq IDX_PC (1+ IDX_PC))
    )
   )
  )
 )

;;Polylines, include those on layers frozen and off
 (ssget "_X" (quote ((0 . "LWPOLYLINE,POLYLINE"))))
 (setq SEL (vla-get-activeselectionset ACDC))
 (if (> (vla-get-count SEL) 0)
  (vlax-for Obj SEL
   (setq LSC (vlax-safearray->list (vlax-variant-value (vla-get-coordinates Obj))))
   (if (and
        (= (length LSC) 4)
        (equal (car  LSC) (caddr  LSC) FUZ)
        (equal (cadr LSC) (cadddr LSC) FUZ)
        (not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list Obj))))
       )
    (setq IDX_PL (1+ IDX_PL))
   )
  )
 )

;;Lines and Arcs, include those on layers frozen and off
 (ssget "_X" (quote ((0 . "LINE,ARC"))))
 (setq SEL (vla-get-activeselectionset ACDC))
 (if (> (vla-get-count SEL) 0)
  (vlax-for Obj SEL
   (if (and
        (equal (vlax-safearray->list (vlax-variant-value (vla-get-endpoint   Obj)))
               (vlax-safearray->list (vlax-variant-value (vla-get-startpoint Obj)))
               FUZ
        )
        (not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list Obj))))
       )
    (setq IDX_LA (1+ IDX_LA))
   )
  )
 )

;;Texts and Mtexts, include those on layers frozen and off
 (ssget "_X" (quote ((0 . "TEXT,MTEXT"))))
 (setq SEL (vla-get-activeselectionset ACDC))
 (if (> (vla-get-count SEL) 0)
  (vlax-for Obj SEL
   (if (and
         (wcmatch (vla-get-textstring Obj) ", ") ;;Blank text
         (not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list Obj))))
       )
    (setq IDX_TX (1+ IDX_TX))
   )
  )
 )

;; (prompt (strcat "\nVersion I: "  (rtos (* 1E7 (- (getvar "CDATE") CDA)) 2 3))) ;;Test Version I (tenths of a second)
       ;;;;;;;;;;;;;;;;;;;;;;
       ;;                  ;;
       ;;    VERSION II    ;;
       ;;                  ;;
       ;;;;;;;;;;;;;;;;;;;;;;
;|
 (ssget "_X" (quote ((0 . "POINT,LWPOLYLINE,POLYLINE,LINE,ARC,TEXT,MTEXT"))))
 (setq SEL (vla-get-activeselectionset ACDC))
 (if (> (vla-get-count SEL) 0)
  (vlax-for Obj SEL
   (cond
    ( (= (vla-get-objectname Obj) "AcDbPoint")
     (setq LAY (vla-item LAYS (vla-get-layer Obj)))
     (if (equal (list (vla-get-freeze LAY) (vla-get-layeron LAY) (vla-get-lock LAY))
                (quote (:VLAX-FALSE :VLAX-TRUE :VLAX-FALSE))
         )
       (progn
        (vla-delete Obj)
        (setq IDX_PC (1+ IDX_PC))
       )
     )
    )
    ( (= (vla-get-objectname Obj) "AcDbPolyline")
     (setq LSC (vlax-safearray->list (vlax-variant-value (vla-get-coordinates Obj))))
     (if (and
          (= (length LSC) 4)
          (equal (car  LSC) (caddr  LSC) FUZ)
          (equal (cadr LSC) (cadddr LSC) FUZ)
          (not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list Obj))))
         )
      (setq IDX_PL (1+ IDX_PL))
     )
    )
    ( (vl-position (vla-get-objectname Obj) (quote ("AcDbLine" "AcDbArc")))
     (if (and
          (equal (vlax-safearray->list (vlax-variant-value (vla-get-endpoint   Obj)))
                 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint Obj)))
                 FUZ
          )
         (not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list Obj))))
       )
      (setq IDX_LA (1+ IDX_LA))
     )
    )
    ( (vl-position (vla-get-objectname Obj) (quote ("AcDbText" "AcDbMText")))
     (if (and
          (wcmatch (vla-get-textstring Obj) ", ")
          (not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list Obj))))
       )
      (setq IDX_TX (1+ IDX_TX))
     )
    )
    (T nil)
   )
  )
 )
;; (prompt (strcat "\nVersion II: "  (rtos (* 1E7 (- (getvar "CDATE") CDA)) 2 3))) ;;Test Version II (tenths of a second)
|;

 (setq SEL (prompt
             (strcat
               "\n" (rtos IDX_PC 2 0) " Points found"
               "\n" (rtos IDX_PL 2 0) " Polylines with zero length found"
               "\n" (rtos IDX_LA 2 0) " Lines and Arcs with zero length found"
               "\n" (rtos IDX_TX 2 0) " empty (M)Texts found"
               "\n" (rtos (+ IDX_PC IDX_PL IDX_LA IDX_TX) 2 0) " deleted"
             )
           )
 )
 (vlax-release-object LAYS)
 (vlax-release-object ACDC)
 (princ)
) ;;C:DELPO

Thank you.

DelPo.lsp

March 11, 2020

So what's your objective? Find all curves that have zero length? and empty mtexts?

March 11, 2020

I'd take it that you'd like to delete those points and lines that are of zero length or fuzz. This one might still be a bit slow due to freezing and locking layers, but if not for that, it should work quite fast.

(defun JH:selset-to-vla (selset / lst iter) ; Returns all entities within a selection set into a list of vla objects.
  (setq iter 0)
  (repeat (sslength selset)
    (setq lst (cons (vlax-ename->vla-object (ssname selset iter)) lst)
	  iter (1+ iter))
    )
  (reverse lst)
  )

(defun C:DELPO ( / *error* activeundo acadobj adoc crv crvzero fuz lay laystate msp nolay pts ss txt txtnil vss xlays)
  (defun *error* ( msg )
    (vla-EndUndoMark adoc)
    (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
      (princ (strcat "Error: " msg))
      )
    )
  (setq acadobj (vlax-get-acad-object)
        adoc (vla-get-ActiveDocument acadobj)
        msp (vla-get-ModelSpace adoc)
        activeundo nil
	fuz 1e-8	; <--- set fuzz here
	)
  (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

  (while (setq xlays (tblnext "LAYER" (not xlays)))
    (if
      (or
	(minusp (cdr (assoc 62 xlays)))
	(= 1 (logand 1 (cdr (assoc 70 xlays))))
	(= 4 (logand 4 (cdr (assoc 70 xlays))))
	)
      (setq nolay (cons (cdr (assoc 2 xlays)) nolay))
      )
    )
  
  (if (setq ss (ssget "_X" '((0 . "POINT,*LINE,ARC,*TEXT"))))
    (progn
      (setq crv (vl-remove-if-not '(lambda (x) (vlax-property-available-p x "Length")) (setq vss (JH:selset-to-vla ss)))
	    crvzero (vl-remove-if-not '(lambda (x) (<= (vla-get-Length x) fuz)) crv)
	    txt (vl-remove-if-not '(lambda (x) (vlax-property-available-p x "TextString")) vss)
	    txtnil (vl-remove-if-not '(lambda (x) (wcmatch (vla-get-TextString x) ", ")) txt)
	    pts (vl-remove-if-not '(lambda (x)
				     (and
				       (wcmatch (vla-get-ObjectName x) "*Point")
				       (null (member (vla-get-Layer x) nolay))
				       )
				     )
		  vss
		  )
	    )

      (mapcar '(lambda (y / lay)
		 (setq laystate (cons
				  (list y
					(vla-get-Freeze (setq lay (vla-item (vla-get-layers adoc) y)))
					(vla-get-Lock lay)
					)
				  laystate
				  )
		       )
		 (vl-catch-all-apply 'vla-put-Freeze (list lay :vlax-false))
		 (vla-put-Lock lay :vlax-false)
		 )
	      nolay
	      )
      
      (foreach x
	       (mapcar 'vlax-vla-object->ename
		       (append crvzero txtnil pts)
		       )
	(entdel x)
	)

      (mapcar '(lambda (y)
		 (vl-catch-all-apply 'vla-put-Freeze (list (vla-item (vla-get-layers adoc) (car y)) (cadr y)))
		 (vla-put-Lock (vla-item (vla-get-layers adoc) (car y)) (last y))
		 )
	      laystate
	      )
      (alert
	(strcat
	  (itoa (length pts)) " points deleted\n"
	  (itoa (length txtnil)) " empty texts deleted\n"
	  (itoa (length crvzero)) " zero-length curves deleted\n"
	  )
	)
      )
    )
  (if activeundo nil (vla-EndUndoMark adoc))
  (princ)
  )

March 11, 2020

You could do everything with minimal VL

(DEFUN C:DELPO (/ *error* FUZ IDX_LA IDX_PC IDX_PL IDX_TX ss cnt ent obj e_lst typ l_lst locked)
;; (setq CDA (getvar "CDATE")) ;;For tests

 (defun *error* (s)
  (or (wcmatch (strcase s) "*BREAK,*CANCEL*,*EXIT*") (prompt (strcat "\nError: " s)))
  (princ)
 ) ;;*error*

  (setq FUZ 1.0E-7 IDX_LA 0 IDX_PC 0 IDX_PL 0 IDX_TX 0);COUNTERS SHOULD BE INTEGERS (YOU CAN'T DELETE PART OF AN OBJECT ONLY MODIFY IT)

  (setq ss (ssget "_X" '((0 . "LWPOLYLINE,POLYLINE,POINT,LINE,ARC,*TEXT"))))
  (cond (ss
          (repeat (setq cnt (sslength ss))
            (setq ent (ssname ss (setq cnt (1- cnt)))
                  obj (vlax-ename->vla-object ent)
                  elst (entget ent)
                  typ (cdr (assoc 0 elst))
                  l_lst (entget (tblobjname "layer" (cdr (assoc 8 e_lst))))
                  locked (= 4 (logand 4 (cdr (assoc 70 l_lst))))
                  off (minusp (cdr (assoc 62 l_lst)))
                  frz (= 1 (logand 1 (cdr (assoc 70 l_lst))))
            )
            (cond ( (= typ "POINT")
                    (cond ( (and (not frz) (not off) (not locked))
                            (vla-delete obj)
                            (setq IDX_PC (1+ IDX_PC))
                          )
                    );end_cond
                  )
                  ( (vl-position typ (list "LWPOLYLINE" "POLYLINE"))
                    (cond ( (and (not locked) (equal (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 0.0 fuz))
                            (vla-delete obj)
                            (setq IDX_PL (1+ IDX_PL))
                          )
                    );end_cond
                  )
                  ( (vl-position typ (list "LINE" "ARC")) 
                    (cond ( (and (not locked) (equal (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 0.0 fuz))
                            (vla-delete obj)
                            (setq IDX_LA (1+ IDX_LA))
                          )
                    );end_cond
                  )
                  ( (vl-position typ (list "TEXT" "MTEXT"))
                    (cond ( (and (not locked) (= "" (vl-string-trim ", " (cdr assoc 1 elst))))
                            (vla-delete obj)
                            (setq IDX_TX (1+ IDX_TX))
                          )
                    );end_cond
                  )
            );end_cond
          );end_repeat
          (princ (strcat "\n" (itoa IDX_PC) " Points found"
                         "\n" (itoa IDX_PL) " Polylines with zero length found"
                         "\n" (itoa IDX_LA) " Lines and Arcs with zero length found"
                         "\n" (itoa IDX_TX) " empty (M)Texts found"
                         "\n" (itoa (+ IDX_PC IDX_PL IDX_LA IDX_TX)) " deleted"
                  );end_strcat
          );end_princ
        )
        (t (princ "\nNothing Found"))
  );end_cond
  (princ)
);end_defun


;; (prompt (strcat "\nVersion I: "  (rtos (* 1E7 (- (getvar "CDATE") CDA)) 2 3))) ;;Test Version I (tenths of a second)

Since you're only checking for zero length the LINES & ARC could be combined with the POLYLINES as the method is exactly the same.

March 11, 2020

3 minutes ago, dlanorh said:

(vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))

Can be reduced to (vla-get-length ent)

March 11, 2020

3 hours ago, Jonathan Handojo said:

Can be reduced to (vla-get-length ent)

You mean: (vla-get-length OBJ)

FWIW .. I like the curve method better since you can use it on enames and will return the length for all curve objects ( arcs, splines etc... )

March 11, 2020

Thank Jonathan Handojo and dlanorh for your answers.

@dlanorh

1. Your proposed code failed. Did you try to run it at least one time?

2. "You could do everything with minimal VL" What about VL functions? Please support your statement.

3. Statement "COUNTERS SHOULD BE INTEGERS" is not correct. It is not intended to go into details but please try:

(itoa 2147483647)

and

(itoa 2147483648)

Other ideas?

March 11, 2020

1 hour ago, ronjonp said:

You mean: (vla-get-length OBJ)

FWIW .. I like the curve method better since you can use it on enames and will return the length for all curve objects ( arcs, splines etc... )

Oops... Yes, obj... Not ent.

I get what you mean. I mean at one stage you'll have to check if the entity is a curve. For example, simply doing (ssget '((0 . "*LINE"))) won't really give you all lines, because MLINE also falls under that category, and certainly you can't run that on MLINE. I just came to believe that all curves have a defined length, which is why I did the above.

Edited March 11, 2020 by Jonathan Handojo

March 12, 2020

1 hour ago, lido said:
Thank Jonathan Handojo and dlanorh for your answers.

@dlanorh

1. Your proposed code failed. Did you try to run it at least one time?

2. "You could do everything with minimal VL" What about VL functions? Please support your statement.

3. Statement "COUNTERS SHOULD BE INTEGERS" is not correct. It is not intended to go into details but please try:
(itoa 2147483647)

and

(itoa 2147483648)
Other ideas?

1. No, not tested as I don't currently have access to a full Autocad until tomorrow. If it breaks I will find out why then, although I'm 99.9% certain it's the mis-spelled e_lst in the tblobjname line that is causing it to fail (it should be elst).

2. VLA functions are slower as they are wrapper functions for activex calls. Converting to/from variants is slow. Processing 4 object selection sets (create ->get set as objects ->process) is slower than one pass through a larger set using entities as all the properties you need are are in one list, the entity list. The rest is referencing the list (fast) as opposed to property gets.

Using vlax-get-property & vlax-invoke-method is better, using the undocumented vlax-get /vlax-invoke (which negate any sort of conversions) are faster still. I've used some VL because vl-position is approx 3.5x faster than using member (tests), and vla-delete instead of erase.

3. OK so a 32bit integer overflow produces a real; but in the real world I doubt AutoCAD could load or do anything with a drawing containing 2147483647 entities; when you consider how many properties each entity has and using a conservative estimate of 0.5 Kb per entity that gives you a drawing size in excess of 1Tb (terrabyte).

Aside from that, a selection set has a max limit of 32767 entities (default IIRC is 25,000) so you are never going to exceed the integer limit, and integer addition is quicker than real addition, as the numbers take up less bits/bytes.

Why is your fuzz so small? If your drawing linear accuracy is set to 3 decimal places anything under 5.0e-4 long will report as zero length

March 12, 2020

20 hours ago, Jonathan Handojo said:

Oops... Yes, obj... Not ent.

I get what you mean. I mean at one stage you'll have to check if the entity is a curve. For example, simply doing (ssget '((0 . "*LINE"))) won't really give you all lines, because MLINE also falls under that category, and certainly you can't run that on MLINE. I just came to believe that all curves have a defined length, which is why I did the above.

Try this: (vla-get-length arcobj)

FWIW I use a sledgehammer approach along with some filtering..

(defun _getlength (e / ep)
  (if (vl-catch-all-error-p (setq ep (vl-catch-all-apply 'vlax-curve-getendparam (list e))))
    0.
    (vlax-curve-getdistatparam e ep)
  )
)

Edited March 12, 2020 by ronjonp

March 12, 2020

For whom would be concerned.

;Delete Points, Polylines, 3DPolylines, Splines, Arcs, MLines and Lines of null length, Texts and MText without content
(DEFUN C:DELPO (/ *error* DELO SELO ACDC COO FUZ IDX_LA IDX_ML IDX_PC IDX_PL IDX_TX LAY LAYS SEL)

	(defun *error* (s)
		(or	(wcmatch (strcase s) "*BREAK,*CANCEL*,*EXIT*") (prompt (strcat "\nError: " s)))
		(princ)
	) ;;*error*

	(defun DELO (o)
		(not (vl-catch-all-error-p (vl-catch-all-apply (function vla-delete) (list o))))
	) ;;DELO

	(defun SELO (s)
		(ssget "_X" (list (cons 0 s)))
		(vla-get-activeselectionset ACDC)
	) ;;SELO

	(setq			ACDC	(vla-get-activedocument (vlax-get-acad-object))
					FUZ		1E-5
					IDX_LA 	0
					IDX_ML 	0
					IDX_PC 	0
					IDX_PL 	0
					IDX_TX 	0
					LAYS	(vla-get-layers ACDC)
	)

;;Points, exclude those on layers frozen, off and lock
	(setq SEL (SELO "POINT"))
	(if (> (vla-get-count SEL) 0)
		(vlax-for Obj SEL
			(setq LAY (vla-item LAYS (vla-get-layer Obj)))
			(if	(equal	(list (vla-get-freeze LAY) (vla-get-layeron LAY) (vla-get-lock LAY))
						(quote (:VLAX-FALSE :VLAX-TRUE :VLAX-FALSE))
					)
				(progn
					(vla-delete Obj)
					(setq IDX_PC (1+ IDX_PC))
				)
			)
		)
	)

;;Polylines, include those on layers frozen and off
	(setq SEL (SELO "*POLYLINE"))
	(if (> (vla-get-count SEL) 0)
		(vlax-for Obj SEL
			(if	(and
					(equal  (vla-get-length Obj) 0 FUZ)
					(DELO Obj) ;Avoid delete Obj on lock layer
				)
				(setq IDX_PL (1+ IDX_PL))
			)
		)
	)

;;Lines and Arcs, include those on layers frozen and off
	(setq SEL (SELO "LINE,ARC,SPLINE"))
	(if (> (vla-get-count SEL) 0)
		(vlax-for Obj SEL
			(if	(and
					(equal (vlax-curve-getdistatparam Obj (vlax-curve-getendparam Obj)) 0 FUZ)
					(DELO Obj) ;Avoid delete Obj on lock layer
				)
				(setq IDX_LA (1+ IDX_LA))
			)
		)
	)

;;MLines, include those on layers frozen and off
	(setq SEL (SELO "MLINE"))
	(if (> (vla-get-count SEL) 0)
		(vlax-for Obj SEL
			(setq COO (vlax-variant-value (vla-get-coordinates Obj)))
			(if	(and
					(equal	(mapcar (function (lambda (x) (vlax-safearray-get-element COO x))) (quote (0 1 2)))
							(mapcar (function (lambda (x) (vlax-safearray-get-element COO x))) (quote (3 4 5)))
							FUZ
					)
					(DELO Obj) ;Avoid delete Obj on lock layer
				)
				(setq IDX_ML (1+ IDX_ML))
			)
		)
	)

;;Texts and Mtexts, include those on layers frozen and off
	(setq SEL (SELO "*TEXT"))
	(if (> (vla-get-count SEL) 0)
		(vlax-for Obj SEL
			(if	(and
					(wcmatch (vla-get-textstring Obj) ", ") ;;Blank text
					(DELO Obj) ;Avoid delete Obj on lock layer
				)
				(setq IDX_TX (1+ IDX_TX))
			)
		)
	)

;;Princ results
	(setq SEL (prompt
				(strcat
					"\n" (itoa IDX_PC) " Points found"
					"\n" (itoa IDX_PL) " (3D)Plines of zero length found"
					"\n" (itoa IDX_LA) " Curves of zero length found"
					"\n" (itoa IDX_ML) " MLines of zero length found"
					"\n" (itoa IDX_TX) " empty (M)Texts found"
					"\n" (itoa (+ IDX_PC IDX_PL IDX_LA IDX_ML IDX_TX)) " deleted"
				)
			)
	)

	(vlax-release-object LAYS)
	(vlax-release-object ACDC)
	(princ)
)

Sign In

Delete trash from the drawing

Recommended Posts

lido

Jonathan Handojo

Jonathan Handojo

dlanorh

Jonathan Handojo

ronjonp

lido

Jonathan Handojo

dlanorh

ronjonp

lido

Join the conversation

Tutorials

Forums

Activity