erase block which have common insertion points

dear all,
can anybody help me to develop a program to "erase the blocks which are lies in one insertion points" . I am facing this problem when counting the blocks through quick select ,where I am getting more number of blocks than the number of blocks in the "hard copy".

best regards

biju

 

If you mean to delete copies of the blocks with zero displacement from original, try this routine:

Code:

(defun pl:bl-del-copy (/ adoc lays sela selb sels snm1 snm2)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
snm1 "pl-temp-selection-base"
snm2 "pl-temp-selection-temp"
sels (vla-get-selectionsets adoc)
lays (vla-get-layers adoc)
)
(if (vl-catch-all-error-p
(setq sela (vl-catch-all-apply (function vla-item) (list sels snm1)))
)
(setq sela (vla-add sels snm1))
)
(vla-clear sela)
(if (vl-catch-all-error-p
(setq selb (vl-catch-all-apply (function vla-item) (list sels snm2)))
)
(setq selb (vla-add sels snm2))
)
(vla-select
sela
acselectionsetall
nil
nil
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
(vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0)) '("INSERT"))
)
(vlax-for x sela
(vla-clear selb)
(vla-select
selb
acselectionsetall
nil
nil
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 2)) '(0 2 10))
(vlax-safearray-fill
(vlax-make-safearray vlax-vbvariant '(0 . 2))
(list "INSERT" (vla-get-name x) (vla-get-insertionpoint x))
)
)
(vla-removeitems
selb
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject '(0 . 0))
(list (vla-item selb 0))
)
)
)
(vlax-for y selb
(vla-removeitems
sela
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray vlax-vbobject '(0 . 0)) (list y))
)
)
(vl-catch-all-apply (function vla-delete) (list y))
)
)
(vla-delete sela)
(vla-delete selb)
)

(defun c:bldelc () (pl:bl-del-copy) (princ))

(princ "\nCommand line: bldelc")

(princ)

regards

 

I get a stringp nil error when trying to load the lisp defined below.

 

Try add (vl-load-com) at first line of the LSP-file:

Code:

(vl-load-com)
(defun pl:bl-del-copy (/ adoc lays sela selb sels snm1 snm2 ownr)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
...

if this will be not enough, send error string.

 

Great routine...thanks for sharing it. I added a few things...
In adding your routine to my library, I will like to add your
full name...if you don't mind.

Thanks again.

Gary



(defun ARCHOSLIBLOADER ()
(cond
((and (>= (distof (substr (getvar "acadver") 1 4)) 15.0)
(< (distof (substr (getvar "acadver") 1 4)) 16.0)
)
(if (not (member "doslib2k.arx" (arx)))
(arxload (findfile (strcat ARCH#SUPF "V_15\\doslib2k.arx")))
)
)
((>= (distof (substr (getvar "acadver") 1 4)) 16.0)
(if (not (member "doslib2004.arx" (arx)))
(arxload
(findfile (strcat ARCH#SUPF "V_16\\doslib2004.arx"))
)
)
)
)
(princ)
)
(ARCHOSLIBLOADER);;loads doslib2004.arx

(defun ARCH:WARNING-5 (TT LN1 LN2 LN3 LN4 LN5 / X1 X2 txmsg buttons)
(setq ARCH#LOGO "Arch Program")
(setq X1 " Please Make a Selection\n")
(setq X2
"--------------------------------------------------------------------------------
------------\n")
(setq txmsg (strcat X1 X2 LN1 LN2 LN3 LN4 LN5))
(setq buttons (list "Yes" "No"))
(dos_msgboxex
txmsg
(strcat ARCH#LOGO " : " TT)
buttons
5))
;;;delete copies of the blocks with zero displacement from original, try this
routine:
;;;Alaspher
(defun pl:bl-del-copy (/ adoc lays sela selb sels snm1 snm2)
(vl-load-com) ;;added here
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
snm1 "pl-temp-selection-base"
snm2 "pl-temp-selection-temp"
sels (vla-get-selectionsets adoc)
lays (vla-get-layers adoc)
)
(if (vl-catch-all-error-p
(setq sela (vl-catch-all-apply (function vla-item) (list sels snm1)))
)
(setq sela (vla-add sels snm1))
)
(vla-clear sela)
(if (vl-catch-all-error-p
(setq selb (vl-catch-all-apply (function vla-item) (list sels snm2)))
)
(setq selb (vla-add sels snm2))
)
(vla-select
sela
acselectionsetall
nil
nil
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
(vlax-safearray-fill (vlax-make-safearray vlax-vbvariant '(0 . 0))
'("INSERT"))
)
(vlax-for x sela
(vla-clear selb)
(vla-select
selb
acselectionsetall
nil
nil
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 2)) '(0 2
10))
(vlax-safearray-fill
(vlax-make-safearray vlax-vbvariant '(0 . 2))
(list "INSERT" (vla-get-name x) (vla-get-insertionpoint x))
)
)
(vla-removeitems
selb
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject '(0 . 0))
(list (vla-item selb 0))
)
)
)
(vlax-for y selb
(vla-removeitems
sela
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray vlax-vbobject '(0 . 0)) (list
y))
)
)
(vl-catch-all-apply (function vla-delete) (list y))
)
)
(vla-delete sela)
(vla-delete selb)
(princ "\n* Duplicate Blocks w/same Insertion Point have been Deleted
*");;added here
)
(defun DELBLKCOPYIT ()
(setq Result
(ARCH:WARNING-5
"Block Tools"
" This will Delete All Copies of Blocks, that have the\n"
" same Insertion Point..\n\n"
" [ Yes ]\t to continue on...\n"
" [ No ]\t to Cancel command."
""
)
)
(if (= Result 0)(pl:bl-del-copy))
(if (= Result 1)(princ "\n*** ///////// Program CANCELLED ///////// ***"))
(princ)
)
(princ)
(defun CELBC () (DELBLKCOPYIT))

 

Sometimes I get this error: Automation Error. Invalid argument index in Item

Gary

 

Hi, Gary!

I can't get same error, as is it >Automation Error. Invalid argument index in Item<
May be you've some troubles because you use first edition of the code (in other your post) - my first message was edited Nov/27/04. Try to use current edition and if error will appear send me a file where it'll happened (if it's possible). Mailbox = my nickname, mail server - uniip.ru (no more 5Mb - mailbox limit for one message). May be cause of troubles is in a proxy graphics or a file errors.

My full name is: Peter V. Loskutov

Regards
Alaspher

 

I placed the file in "Commond Insertion Points" in the Customer-Files site.
This file gave me the error.

Thanks

Gary

your post) - my first message was edited Nov/27/04. Try to use current edition
and if error will appear send me a file where it'll happened (if it's possible).
Mailbox = my nickname, mail server - uniip.ru (no more 5Mb - mailbox limit for
one message). May be cause of troubles is in a proxy graphics or a file errors.

 

Modified again:

Code:

(defun pl:bl-del-copy (/ adoc lays sela selb sels snm1 snm2 ownr ondel)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
snm1 "pl-temp-selection-base"
snm2 "pl-temp-selection-temp"
sels (vla-get-selectionsets adoc)
lays (vla-get-layers adoc)
)
(if (vl-catch-all-error-p
(setq sela (vl-catch-all-apply (function vla-item) (list sels snm1)))
)
(setq sela (vla-add sels snm1))
)
(vla-clear sela)
(if (vl-catch-all-error-p
(setq selb (vl-catch-all-apply (function vla-item) (list sels snm2)))
)
(setq selb (vla-add sels snm2))
)
(vla-select
sela
acselectionsetall
nil
nil
(vlax-safearray-fill (vlax-make-safearray vlax-vbinteger '(0 . 0)) '(0))
(vlax-safearray-fill
(vlax-make-safearray vlax-vbvariant '(0 . 0))
'("INSERT")
)
)
(vlax-for x sela
(if (not (vl-position x ondel))
(progn
(vla-clear selb)
(vla-select
selb
acselectionsetall
nil
nil
(vlax-safearray-fill
(vlax-make-safearray vlax-vbinteger '(0 . 7))
'(0 2 8 10 41 42 43 50)
)
(vlax-safearray-fill
(vlax-make-safearray vlax-vbvariant '(0 . 7))
(list "INSERT"
(vla-get-name x)
(vla-get-layer x)
(vla-get-insertionpoint x)
(vla-get-xscalefactor x)
(vla-get-yscalefactor x)
(vla-get-zscalefactor x)
(vla-get-rotation x)
)
)
)
(vla-removeitems
selb
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject '(0 . 0))
(list x)
)
)
)
(setq ownr (vla-get-ownerid x))
(vlax-for y selb
(if (= (vla-get-ownerid y) ownr)
(setq ondel (cons y ondel))
)
)
)
)
)
(vla-delete sela)
(vla-delete selb)
(pl:del-force-lst adoc ondel)
)

(defun pl:del-force-lst (doc lst / lay lays frz lck yes err)
(setq lays (vla-get-layers doc)
yes  0
err  0
)
(foreach x lst
(setq lay (vla-item lays (vla-get-layer x)))
(if (= (vla-get-freeze lay) :vlax-true)
(progn
(setq frz (cons lay frz))
(vla-put-freeze lay :vlax-false)
)
)
(if (= (vla-get-lock lay) :vlax-true)
(progn
(setq lck (cons lay lck))
(vla-put-lock lay :vlax-false)
)
)
(cond ((vl-catch-all-error-p
(vl-catch-all-apply (function vla-delete) (list x))
)
(setq err (1+ err))
)
(t (setq yes (1+ yes)))
)
)
(foreach x frz (vla-put-freeze x :vlax-true))
(foreach x lck (vla-put-lock x :vlax-true))
(list yes err)
)

(defun c:bldelc (/ res)
(setq res (pl:bl-del-copy))
(princ "\nDeleted - ")
(princ (car res))
(princ ", errors - ")
(princ (cadr res))
(princ)
)

(princ "\nCommand line: bldelc")
(princ)

This code should be more safety than previous and insertions on the frozen and locked layers is deletes now.

 

Thanks

I still get this error...

Command: ; error: Automation Error. Description was not provided.

I placed anothr file in the customer files in folder "command insertion points"

Thanks for taking the time to check this out....what does the error message mean?

Gary

locked layers is deletes now.

 

Command: ; error: Automation Error. Description was not provided.

This mean that some object not ready (may be temporary) for an action which applying for it. Why? I can't say without view to that file.

I make new release of this function without any Active X manipulations. Try the code below:

Code:

(defun pl:bl-del-copy (/ sela ondel xget)
(setq sela (pl:sel-to-list (ssget "_X" '((0 . "INSERT")))))
(foreach x sela
(if (not (vl-position x ondel))
(setq xget  (entget x)
ondel (append ondel
(vl-remove x
(pl:sel-to-list
(ssget "_X"
(list '(0 . "INSERT")
(assoc 2 xget)
(assoc 8 xget)
(assoc 10 xget)
(assoc 41 xget)
(assoc 42 xget)
(assoc 43 xget)
(assoc 50 xget)
(assoc 410 xget)
)
)
)
)
)
)
)
)
(pl:del-force-ent-lst ondel)
)

(defun pl:del-force-ent-lst (lst / lay lget frz lck err k70 key yes)
(setq yes 0
err 0
)
(foreach x lst
(setq lay  (tblobjname "layer" (cdr (assoc 8 (entget x))))
lget (entget lay)
k70  (assoc 70 lget)
key  (cdr k70)
)
(if (not (zerop (logand key 1)))
(progn (setq frz (cons lay frz))
(entmod (subst (cons 70 (- key 1)) k70 lget))
)
)
(if (not (zerop (logand key 4)))
(progn (setq lck (cons lay lck))
(entmod (subst (cons 70 (- key 4)) k70 lget))
)
)
(cond ((vl-catch-all-error-p
(vl-catch-all-apply (function entdel) (list x))
)
(setq err (1+ err))
)
(t (setq yes (1+ yes)))
)
)
(foreach x frz
(setq lget (entget x)
k70  (assoc 70 lget)
)
(entmod (subst (cons 70 (+ (cdr k70) 1)) k70 lget))
)
(foreach x lck
(setq lget (entget x)
k70  (assoc 70 lget)
)
(entmod (subst (cons 70 (+ (cdr k70) 4)) k70 lget))
)
(list yes err)
)

(defun pl:sel-to-list (ss / i ename result)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq result (cons ename result))
)
)

(defun c:bldelc (/ res)
(setq res (pl:bl-del-copy))
(princ "\nDeleted - ")
(princ (car res))
(princ ", errors - ")
(princ (cadr res))
(princ)
)

(princ "\nCommand line: bldelc")
(princ)

I have not enough time for complete testing so be attentive.

P.S. Sorry, my English isn't good because isn't native.

Regards

 

Thanks...works perfectly now.

Gary

applying for it. Why? I can't say without view to that file.