Jump to content

Need modification-Block & Entity Color Change


xpr0

Recommended Posts

(defun c:blcc () (pl:block-color) (princ))
 
(defun c:encc () (pl:block-ent-color) (princ))
 
;;;get from Alaspher http://forum.dwg.ru/showthread.php?t=1036
 
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
 
(vl-load-com)
 
(defun pl:block-ent-color (/ adoc blocks color ent lays)
 
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
 
lays (vla-get-layers adoc)
 
color (acad_colordlg 256)
 
)
 
(if color
 
(progn (setvar "errno" 0)
 
(vla-startundomark adoc)
 
(while (and (not (vl-catch-all-error-p
 
(setq ent (vl-catch-all-apply
 
(function nentsel)
 
'("\nSelect entity <Exit>:")
 
)
 
)
 
)
 
)
 
(/= 52 (getvar "errno"))
 
)
 
(if ent
 
(progn (setq ent (vlax-ename->vla-object (car ent))
 
lay (vla-item lays (vla-get-layer ent))
 
)
 
(if (= (vla-get-lock lay) :vlax-true)
 
(progn (setq layloc (cons lay layloc))
 
(vla-put-lock lay :vlax-false)
 
)
 
)
 
(vl-catch-all-apply (function vla-put-color) (list ent color))
 
(vla-regen adoc acallviewports)
 
)
 
(princ "\nNothing selection! Try again.")
 
)
 
)
 
(foreach i layloc (vla-put-lock i :vlax-true))
 
(vla-endundomark adoc)
 
)
 
)
 
(princ)
 
)
 
(defun pl:block-color (/ adoc blocks color ins lays)
 
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
 
blocks (vla-get-blocks adoc)
 
lays (vla-get-layers adoc)
 
color (acad_colordlg 256)
 
)
 
(if color
 
(progn (setvar "errno" 0)
 
(vla-startundomark adoc)
 
(while (and (not (vl-catch-all-error-p
 
(setq ins (vl-catch-all-apply
 
(function entsel)
 
'("\nSelect block <Exit>:")
 
)
 
)
 
)
 
)
 
(/= 52 (getvar "errno"))
 
)
 
(if ins
 
(progn (setq ins (vlax-ename->vla-object (car ins)))
 
(if (= (vla-get-objectname ins) "AcDbBlockReference")
 
(if (vlax-property-available-p ins 'path)
 
(princ "\nThis is external reference! Try pick other.")
 
(progn (_pl:block-color blocks ins color lays)
 
(vla-regen adoc acallviewports)
 
)
 
)
 
(princ "\nThis isn't block! Try pick other.")
 
)
 
)
 
(princ "\nNothing selection! Try again.")
 
)
 
)
 
(vla-endundomark adoc)
 
)
 
)
 
(princ)
 
)
 
(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
 
(vlax-for e (vla-item blocks (vla-get-name ins))
 
(setq lay (vla-item lays (vla-get-layer e)))
 
(if (= (vla-get-freeze lay) :vlax-true)
 
(progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
 
)
 
(if (= (vla-get-lock lay) :vlax-true)
 
(progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
 
)
 
(vl-catch-all-apply (function vla-put-color) (list e color))
 
(if (and (= (vla-get-objectname e) "AcDbBlockReference")
 
(not (vlax-property-available-p e 'path))
 
)
 
(_pl:block-color blocks e color lays)
 
)
 
(foreach i layfrz (vla-put-freeze i :vlax-true))
 
(foreach i layloc (vla-put-lock i :vlax-true))
 
)
 
)
 
(progn
 
(princ "\BLCC - Changes color of the chosen blocks")
 
(princ "\nENCC - Changes color of the chosen objects (may be element of the block)")
 
(princ))

Hello friends, I downloaded this lisp from https://autocadtips1.com/2011/05/01/autolisp-block-entity-color-change/ and i want some modification. it only allows the user to select/pick one entity/block at a time it doesnt allow window selection. plz could someone edit it so that it would also allow the user to select through window selection(solid & crossing). thank you

Edited by xpr0
Link to comment
Share on other sites

(wow, that lack of indentation hurt my eyes ... not your fault, I mean the original post)

 

I added a command BLSS (SS for ssget), which invokes a new function pl:block-color-ssget.

There's a double while loop, so you can change 1 selection of blocks and press enter and the color will be changed,

then you can make another selection, ... or press enter to end the loop.

 

You can still use c:blcc for single select.

And you can still use c:encc for nentsel subentity select.

 

Happy with this?

 

(defun c:blss () (pl:block-color-ssget) (princ))
(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))
;;;get from Alaspher http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
 (vl-load-com)


;; Emmanuel Delay
(defun pl:block-color-ssget (/ adoc blocks color ins lays ss i blocks_done blockname)
  (setq
    adoc (vla-get-activedocument (vlax-get-acad-object))
    blocks (vla-get-blocks adoc)
    lays (vla-get-layers adoc)
    color (acad_colordlg 256)
  )
  (if color
    (progn (setvar "errno" 0)
    (vla-startundomark adoc)
    (setq blocks_done (list))
    (princ "\nSelect block objects, then press Enter: ")
    (while  (setq ss (ssget (list (cons 0 "INSERT"))))
      (setq i 0)
      (while (setq ins (ssname ss i))
        (progn
          (setq ins (vlax-ename->vla-object ins))   ;; we don't need the car here, because (car (entsel)) removes the pick point ...
          (if (= (vla-get-objectname ins) "AcDbBlockReference")
            (if (vlax-property-available-p ins 'path)
              (princ "\nThis is external reference! Try pick other.")
              (progn
                ;; let's skip duplicates
                (setq blockname (vla-get-name ins))
                (if (member blockname blocks_done)  ;; if we already did this block, we skip it
                  (progn
                    (princ "\nSkipping block: ")
                    (princ blockname)
                  )
                  (progn
                    (princ "\n")
                    (setq blocks_done (append blocks_done (list blockname)))
                    (_pl:block-color blocks ins color lays)
                    (vla-regen adoc acallviewports)
                  )
                )
              )
            )
            (princ "\nThis isn't block! Try pick other.")
          )
        )
        (setq i (+ i 1))
      )
    )  ;; / while
    (vla-endundomark adoc)
    )
  )
  (princ)
)
 
(defun pl:block-ent-color (/ adoc blocks color ent lays)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
    lays (vla-get-layers adoc)
    color (acad_colordlg 256)
  )
  (if color
    (progn (setvar "errno" 0)
    (vla-startundomark adoc)
    (while (and (not (vl-catch-all-error-p
    (setq ent (vl-catch-all-apply
    (function nentsel)
    '("\nSelect entity <Exit>:")
    )
    )
    )
    )
    (/= 52 (getvar "errno"))
    )
    (if ent
    (progn
    (setq ent (vlax-ename->vla-object (car ent))
      lay (vla-item lays (vla-get-layer ent))
    )
    (if (= (vla-get-lock lay) :vlax-true)
    (progn (setq layloc (cons lay layloc))
    (vla-put-lock lay :vlax-false)
    )
    )
    (vl-catch-all-apply (function vla-put-color) (list ent color))
    (vla-regen adoc acallviewports)
    )
    (princ "\nNothing selection! Try again.")
    )
    )
    (foreach i layloc (vla-put-lock i :vlax-true))
    (vla-endundomark adoc)
    )
  )
  (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
  blocks (vla-get-blocks adoc)
  lays (vla-get-layers adoc)
  color (acad_colordlg 256)
  )
  (if color
  (progn (setvar "errno" 0)
  (vla-startundomark adoc)
  (while (and (not (vl-catch-all-error-p
  (setq ins (vl-catch-all-apply
  (function entsel)
  '("\nSelect block <Exit>:")
  )
  )
  )
  )
  (/= 52 (getvar "errno"))
  )
  (if ins
  (progn (setq ins (vlax-ename->vla-object (car ins)))
  (if (= (vla-get-objectname ins) "AcDbBlockReference")
  (if (vlax-property-available-p ins 'path)
  (princ "\nThis is external reference! Try pick other.")
  (progn (_pl:block-color blocks ins color lays)
  (vla-regen adoc acallviewports)
  )
  )
  (princ "\nThis isn't block! Try pick other.")
  )
  )
  (princ "\nNothing selection! Try again.")
  )
  )
  (vla-endundomark adoc)
  )
  )
  (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
  (vlax-for e (vla-item blocks (vla-get-name ins))
  (setq lay (vla-item lays (vla-get-layer e)))
  (if (= (vla-get-freeze lay) :vlax-true)
  (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
  )
  (if (= (vla-get-lock lay) :vlax-true)
  (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
  )
  (vl-catch-all-apply (function vla-put-color) (list e color))
  (if (and (= (vla-get-objectname e) "AcDbBlockReference")
  (not (vlax-property-available-p e 'path))
  )
  (_pl:block-color blocks e color lays)
  )
  (foreach i layfrz (vla-put-freeze i :vlax-true))
  (foreach i layloc (vla-put-lock i :vlax-true))
  )
)

 

(progn
  (princ "\nBLSS - Changes color of a window selection of blocks")
  (princ "\nBLCC - Changes color of the chosen blocks")
  (princ "\nENCC - Changes color of the chosen objects (may be element of the block)")
  (princ)
)

Edited by Emmanuel Delay
Link to comment
Share on other sites

Thankyou Emmanuel for your effort it works great on blocks. but i also want it to work on all other objects as well, i think i should've been more clear when i said 'entity' in the 1st post i meant line, pline, mtext, text, arcs etc. in other words 'encc' with the option of window selection. plz could you modify it accordingly.

Link to comment
Share on other sites

Okay

 


(defun c:blss () (pl:block-color-ssget) (princ))
(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))
;;;get from Alaspher http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
 (vl-load-com)
 
(defun pl:block-color-ssget (/ adoc blocks color ins lays ss i blocks_done blockname)
  (setq
    adoc (vla-get-activedocument (vlax-get-acad-object))
    blocks (vla-get-blocks adoc)
    lays (vla-get-layers adoc)
    color (acad_colordlg 256)
  )
  (if color
    (progn (setvar "errno" 0)
    (vla-startundomark adoc)
    (setq blocks_done (list))
    (princ "\nSelect block objects, then press Enter: ")
    (while  (setq ss (ssget))  ;;  (list (cons 0 "INSERT"))
      (setq i 0)
      (while (setq ins (ssname ss i))
        (if (= "INSERT" (cdr (assoc 0 (entget ins))))
          (progn
            (setq ins (vlax-ename->vla-object ins))   ;; we don't need the car here, because (car (entsel)) removes the pick point ...
            (if (= (vla-get-objectname ins) "AcDbBlockReference")
              (if (vlax-property-available-p ins 'path)
                (princ "\nThis is external reference! Try pick other.")
                (progn
                  ;; let's skip duplicates
                  (setq blockname (vla-get-name ins))
                  (if (member blockname blocks_done)  ;; if we already did this block, we skip it
                    (progn
                      (princ "\nSkipping block: ")
                      (princ blockname)
                    )
                    (progn
                      (princ "\n")
                      (setq blocks_done (append blocks_done (list blockname)))
                      (_pl:block-color blocks ins color lays)
                      (vla-regen adoc acallviewports)
                    )
                  )
                )
              )
              (princ "\nThis isn't block! Try pick other.")
            )
          )
          ;; else, put the color to the entity
          (progn
            (vla-put-color (vlax-ename->vla-object ins) color)
          )
        )
        (setq i (+ i 1))
      )
    )  ;; / while
    (vla-endundomark adoc)
    )
  )
  (princ)
)
 
(defun pl:block-ent-color (/ adoc blocks color ent lays)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
    lays (vla-get-layers adoc)
    color (acad_colordlg 256)
  )
  (if color
    (progn (setvar "errno" 0)
    (vla-startundomark adoc)
    (while (and (not (vl-catch-all-error-p
    (setq ent (vl-catch-all-apply
    (function nentsel)
    '("\nSelect entity <Exit>:")
    )
    )
    )
    )
    (/= 52 (getvar "errno"))
    )
    (if ent
    (progn
    (setq ent (vlax-ename->vla-object (car ent))
      lay (vla-item lays (vla-get-layer ent))
    )
    (if (= (vla-get-lock lay) :vlax-true)
    (progn (setq layloc (cons lay layloc))
    (vla-put-lock lay :vlax-false)
    )
    )
    (vl-catch-all-apply (function vla-put-color) (list ent color))
    (vla-regen adoc acallviewports)
    )
    (princ "\nNothing selection! Try again.")
    )
    )
    (foreach i layloc (vla-put-lock i :vlax-true))
    (vla-endundomark adoc)
    )
  )
  (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
  blocks (vla-get-blocks adoc)
  lays (vla-get-layers adoc)
  color (acad_colordlg 256)
  )
  (if color
  (progn (setvar "errno" 0)
  (vla-startundomark adoc)
  (while (and (not (vl-catch-all-error-p
  (setq ins (vl-catch-all-apply
  (function entsel)
  '("\nSelect block <Exit>:")
  )
  )
  )
  )
  (/= 52 (getvar "errno"))
  )
  (if ins
  (progn (setq ins (vlax-ename->vla-object (car ins)))
  (if (= (vla-get-objectname ins) "AcDbBlockReference")
  (if (vlax-property-available-p ins 'path)
  (princ "\nThis is external reference! Try pick other.")
  (progn (_pl:block-color blocks ins color lays)
  (vla-regen adoc acallviewports)
  )
  )
  (princ "\nThis isn't block! Try pick other.")
  )
  )
  (princ "\nNothing selection! Try again.")
  )
  )
  (vla-endundomark adoc)
  )
  )
  (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
  (vlax-for e (vla-item blocks (vla-get-name ins))
  (setq lay (vla-item lays (vla-get-layer e)))
  (if (= (vla-get-freeze lay) :vlax-true)
  (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
  )
  (if (= (vla-get-lock lay) :vlax-true)
  (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
  )
  (vl-catch-all-apply (function vla-put-color) (list e color))
  (if (and (= (vla-get-objectname e) "AcDbBlockReference")
  (not (vlax-property-available-p e 'path))
  )
  (_pl:block-color blocks e color lays)
  )
  (foreach i layfrz (vla-put-freeze i :vlax-true))
  (foreach i layloc (vla-put-lock i :vlax-true))
  )
)

(progn
  (princ "\nBLSS - Changes color of a window selection of blocks")
  (princ "\nBLCC - Changes color of the chosen blocks")
  (princ "\nENCC - Changes color of the chosen objects (may be element of the block)")
  (princ)
)

  • Thanks 1
Link to comment
Share on other sites

On 8/19/2019 at 3:03 PM, Emmanuel Delay said:

Okay

 

 


(defun c:blss () (pl:block-color-ssget) (princ))
(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))
;;;get from Alaspher http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
 (vl-load-com)
 
(defun pl:block-color-ssget (/ adoc blocks color ins lays ss i blocks_done blockname)
  (setq
    adoc (vla-get-activedocument (vlax-get-acad-object))
    blocks (vla-get-blocks adoc)
    lays (vla-get-layers adoc)
    color (acad_colordlg 256)
  )
  (if color
    (progn (setvar "errno" 0)
    (vla-startundomark adoc)
    (setq blocks_done (list))
    (princ "\nSelect block objects, then press Enter: ")
    (while  (setq ss (ssget))  ;;  (list (cons 0 "INSERT"))
      (setq i 0)
      (while (setq ins (ssname ss i))
        (if (= "INSERT" (cdr (assoc 0 (entget ins))))
          (progn
            (setq ins (vlax-ename->vla-object ins))   ;; we don't need the car here, because (car (entsel)) removes the pick point ...
            (if (= (vla-get-objectname ins) "AcDbBlockReference")
              (if (vlax-property-available-p ins 'path)
                (princ "\nThis is external reference! Try pick other.")
                (progn
                  ;; let's skip duplicates
                  (setq blockname (vla-get-name ins))
                  (if (member blockname blocks_done)  ;; if we already did this block, we skip it
                    (progn
                      (princ "\nSkipping block: ")
                      (princ blockname)
                    )
                    (progn
                      (princ "\n")
                      (setq blocks_done (append blocks_done (list blockname)))
                      (_pl:block-color blocks ins color lays)
                      (vla-regen adoc acallviewports)
                    )
                  )
                )
              )
              (princ "\nThis isn't block! Try pick other.")
            )
          )
          ;; else, put the color to the entity
          (progn
            (vla-put-color (vlax-ename->vla-object ins) color)
          )
        )
        (setq i (+ i 1))
      )
    )  ;; / while
    (vla-endundomark adoc)
    )
  )
  (princ)
)
 
(defun pl:block-ent-color (/ adoc blocks color ent lays)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
    lays (vla-get-layers adoc)
    color (acad_colordlg 256)
  )
  (if color
    (progn (setvar "errno" 0)
    (vla-startundomark adoc)
    (while (and (not (vl-catch-all-error-p
    (setq ent (vl-catch-all-apply
    (function nentsel)
    '("\nSelect entity <Exit>:")
    )
    )
    )
    )
    (/= 52 (getvar "errno"))
    )
    (if ent
    (progn
    (setq ent (vlax-ename->vla-object (car ent))
      lay (vla-item lays (vla-get-layer ent))
    )
    (if (= (vla-get-lock lay) :vlax-true)
    (progn (setq layloc (cons lay layloc))
    (vla-put-lock lay :vlax-false)
    )
    )
    (vl-catch-all-apply (function vla-put-color) (list ent color))
    (vla-regen adoc acallviewports)
    )
    (princ "\nNothing selection! Try again.")
    )
    )
    (foreach i layloc (vla-put-lock i :vlax-true))
    (vla-endundomark adoc)
    )
  )
  (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
  blocks (vla-get-blocks adoc)
  lays (vla-get-layers adoc)
  color (acad_colordlg 256)
  )
  (if color
  (progn (setvar "errno" 0)
  (vla-startundomark adoc)
  (while (and (not (vl-catch-all-error-p
  (setq ins (vl-catch-all-apply
  (function entsel)
  '("\nSelect block <Exit>:")
  )
  )
  )
  )
  (/= 52 (getvar "errno"))
  )
  (if ins
  (progn (setq ins (vlax-ename->vla-object (car ins)))
  (if (= (vla-get-objectname ins) "AcDbBlockReference")
  (if (vlax-property-available-p ins 'path)
  (princ "\nThis is external reference! Try pick other.")
  (progn (_pl:block-color blocks ins color lays)
  (vla-regen adoc acallviewports)
  )
  )
  (princ "\nThis isn't block! Try pick other.")
  )
  )
  (princ "\nNothing selection! Try again.")
  )
  )
  (vla-endundomark adoc)
  )
  )
  (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
  (vlax-for e (vla-item blocks (vla-get-name ins))
  (setq lay (vla-item lays (vla-get-layer e)))
  (if (= (vla-get-freeze lay) :vlax-true)
  (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
  )
  (if (= (vla-get-lock lay) :vlax-true)
  (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
  )
  (vl-catch-all-apply (function vla-put-color) (list e color))
  (if (and (= (vla-get-objectname e) "AcDbBlockReference")
  (not (vlax-property-available-p e 'path))
  )
  (_pl:block-color blocks e color lays)
  )
  (foreach i layfrz (vla-put-freeze i :vlax-true))
  (foreach i layloc (vla-put-lock i :vlax-true))
  )
)

(progn
  (princ "\nBLSS - Changes color of a window selection of blocks")
  (princ "\nBLCC - Changes color of the chosen blocks")
  (princ "\nENCC - Changes color of the chosen objects (may be element of the block)")
  (princ)
)

sorry for the late reply. and thanx for editing the lisp it works as intended but there is a problem, when i used 'BLSS' and select diff. object through window selection and hit enter the drawing slows down and starts to stutter, blink and its takes 3-5 seconds to complete the task. and one more thing it doesnt work on hatch with gradient, if you fix this two issues it'll be great.

thank you once again for your time.

 

Link to comment
Share on other sites

  • 2 months later...

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