need lisp to change nested block color and linetype byblock

[jim78b]

i need please a lisp that  change nested block : color and linetype to byblock i have one but not always works in nested blocks          

 

i attach an example where you can try to edit in place block load bb.lsp and select the block:VIBRAT PIANTA 6 mq the linetype not change in by block even the color

nested block.dwg

Edited May 17, 2019 by jim78b
explain more

[jim78b]

 my lisp is:

 

(defun C:BB ()
 (setq blocks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
       grublo (ssget '((0 . "INSERT")))
       ssgetblocks '()
       ssgetblocks1 '()
 )

 (repeat (setq index(sslength grublo))
  (setq ssgetblocks (cons (vla-get-EffectiveName (vlax-ename->vla-object (ssname grublo (setq index(1- index))))) ssgetblocks))
 )

 (foreach elem ssgetblocks
  (if (not(member elem ssgetblocks1))
   (setq ssgetblocks1 (cons elem ssgetblocks1))
  )
 )
 
 (foreach elem ssgetblocks1
  (setq bloccovl(vla-item blocks elem)
    index 0
  )    

  (repeat (vla-get-Count bloccovl)
   (vla-put-Color (vla-item bloccovl index) 0)
   (vla-put-Linetype (vla-item bloccovl index) "Byblock")
   (setq index (1+ index))
  )

 )

 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acAllViewports)

)

[ronjonp]

Try this:

(defun c:foo (/ d)
  ;; RJP » 2019-05-17
  ;; All blocks to color by block
  (vlax-for a (vla-get-blocks (setq d (vla-get-activedocument (vlax-get-acad-object))))
    (if	(= 0 (vlax-get a 'islayout))
      (vlax-for b a (foreach p '(color linetype) (vl-catch-all-apply 'vlax-put (list b p 0))))
    )
  )
  (vla-regen d acallviewports)
  (princ)
)
(vl-load-com)

 

[jim78b]

sorry but the lisp that you posted is not what i mean, i want select block or more one block at a time and set linetype and color byblock

[ronjonp]

4 hours ago, jim78b said:

sorry but the lisp that you posted is not what i mean, i want select block or more one block at a time and set linetype and color byblock

Not sure what is up with that block but this kludge works:

(defun c:foo ( / d l )
  (cond
    ((setq l (mapcar '(lambda (x) (cdr (assoc 2 (entget x))))
		     (cadddr (nentsel "\nPick a nested block: "))
	     )
     )
     (vlax-for a (vla-get-blocks (setq d (vla-get-activedocument (vlax-get-acad-object))))
       (if (vl-position (vla-get-name a) l)
	 (vlax-for b a (foreach p '(color linetype) (vl-catch-all-apply 'vlax-put (list b p 0))))
       )
     )
     (vla-regen d acallviewports)
    )
  )
  (princ)
)

 

[jim78b]

SORRY but this lisp is not what i want, as i explained before i want a lisp that change color and linetype to byblock with multiselection

[ronjonp]

1 hour ago, jim78b said:

SORRY but this lisp is not what i want, as i explained before i want a lisp that change color and linetype to byblock with multiselection

SORRY, but have you searched for this? .. I'm sure it has been answered many times over. The Swamp  Cadtutor Autodesk

[jim78b]

See mi first post...i nerd ti chance color and linetype to byblock .in nested block and can select more than one block in a Drawing, i think is clear...or sorry for  bad explanation

Edited May 18, 2019 by jim78b

[Mara821]

Hi,

try this one

(vl-load-com)

(defun c:byBlock  (/ col cnt lop sel)
;;;---------------------------------------------------------------------------------------------------------------------
;;; subroutines
  ;; remove duplicated items in list
  (defun LM:unique  (l) ; by Lee Mac
    (if l
      (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))))
  ;; set "by block" to all entities in block definition
  (defun BB:setByBlock  (nam / blc blk)
    (setq blc (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
    (setq blk (vla-item blc nam))
    (vlax-for x  blk
      (vla-put-layer x "0")
      (vla-put-color x acByBlock)
      (vla-put-linetype x "ByBlock")
      (vla-put-linetypescale x 1.0)
      (vla-put-lineweight x acLnWtByBlock)
      (vla-put-entityTransparency x "ByBlock:")
      (vla-put-material x "ByBlock")
      (if (eq (vla-get-objectName x) "AcDbBlockReference")
        (BB:setByBlock (vla-get-effectiveName x))))
      )
;;;---------------------------------------------------------------------------------------------------------------------
;;; main
  (setq lop t)
  (while lop
    (princ "\nSelect blocks: ")
    (if (setq sel (ssget '((0 . "INSERT"))))
      (progn (setq cnt 0)
             (setq col nil)
             (repeat (sslength sel)
               (setq obx (vlax-ename->vla-object (ssname sel cnt)))
               (setq col (cons (vla-get-effectiveName obx) col))
             (setq cnt (1+ cnt)))
      (setq col (LM:unique col))
      (foreach x col (BB:setByBlock x))
      (setq lop nil))
    (princ "\nNo selection")))
(vla-regen (vla-get-ActiveDocument (vlax-get-acad-object)) acActiveViewport)
(princ))

Dynamic blocks don't update and I dont know why. Vla-update doesnť work. Vla-resetBlock works but all dynamic parametres are lost.

[jim78b]

thanks MAra821 you are the best really! it is work fine! good day !! best regards

[jim78b]

CONSIDERING THAT YOU ARE SO GOOD I MIGHT PLEASE CHANGE THIS LISTED?

 

the command rotates and copies once, I want it to rotate and copy x times as in the command copy of autocad is possible?

 

(defun C:RTC (/ gru)
(setq gru (ssget))

(if gru
(progn
(command "_COPY" gru "" (list 0 0)(list 0 0))
(command "_ROTATE" "_P" "")
(princ "\nBase point e primo punto d'angolo: ")
(command pause "_R")
(command (getvar "LASTPOINT"))
(princ "\nSecondo punto d'angolo: ")
(command pause)
(princ "\nAngolo finale: ")
(command pause)
)
)

(princ)
)

 

 

[Mara821]

Something like this?

(defun C:RTC  (/ *error* gru lop ptb)
  (defun *error*  (msg /)
    (if (not (member msg '("Function cancelled" "quit / exit abort")))
      (vl-exit-with-error (princ (strcat "\nError: " msg))))
    (princ))
  (setq gru (ssget))
  (if gru
    (progn (setq lop t)
           (while lop
             (initget "Exit")
             (setq ptb (cond ((getpoint "\nBase point e primo punto d'angolo or [Exit] <Exit>: "))
                             ("Exit")))
             (if (eq ptb "Exit")
               (setq lop nil)
               (progn (command "_COPY" gru "" (list 0 0) (list 0 0))
                      (command "_ROTATE" "_L" "" ptb)
                      (command "_R")
                      (command (getvar "LASTPOINT"))
                      (princ "\nSecondo punto d'angolo: ")
                      (command pause)
                      (princ "\nAngolo finale: ")
                      (command pause))))))
  (princ))

You have to define base point and reference angle with every copy.

[jim78b]

I want define reference angle and base point only 1 time

[Mara821]

I can't do with the preview so at least like this

(defun C:RTC  (/ *error* gru lop ptb ptr pti)
  (defun *error*  (msg /)
    (if (not (member msg '("Function cancelled" "quit / exit abort")))
      (vl-exit-with-error (princ (strcat "\nError: " msg))))
    (princ))
  (setq gru (ssget))
  (if gru
    (progn (setq ptb (getpoint "\nBase point e primo punto d'angolo: "))
           (setq ptr (getpoint "\nSecondo punto d'angolo: "))
           (setq lop t)
           (while lop
             (initget "Exit")
             (setq pti (cond ((getpoint "\nAngolo finale: or [Exit] <Exit>: "))
                             ("Exit")))
             (if (eq pti "Exit")
               (setq lop nil)
               (progn (command "_ROTATE" gru "" ptb "_C" "_R" ptb ptr pti))))))
  (princ))

 

[jim78b]

thanks but don't work as i thought , if you can try the command copy ...i want like that, you can copy x times and then stop when you want ...so the command rtc

[myloveflyer]

(defun c:Change_Col (/ i ent sel obj lst LayLst)
   (setq *App (vlax-get-acad-object))
   (setq *Doc (vla-get-ActiveDocument *APP))
   (setq *BLK (vla-get-blocks *DoC))
   (setq i 0)
   (setq LayLst (Get_Layer_Status *Doc))
   (UnLock_All_Layers *DOC)
   (UnFreeze_All_Layers *DOC)
   (if (setq sel (ssget '((0 . "INSERT"))))
     (repeat (sslength sel)
       (setq ent (ssname sel i))
       (setq obj (vlax-ename->vla-object ent))
       (setq lst (entget ent))
       (change-color obj)
       (setq i (1+ i))
     )
     (princ "\nNo choice of objects!")
   )
   (Restore_Layer_Status LayLst)
   (princ)
)

(defun change-color (obj / name blks)
   (vla-put-color obj AcByLayer) 
   (if (or
  (= (vla-get-objectname obj) "AcDbBlockReference")
  (= (vla-get-objectname obj) "AcDbMInsertBlock")
       )
     (progn
       (foreach Att (vlax-invoke Obj 'GetAttributes)
  (vla-put-layer Att "0")
  (vla-put-Color Att AcByLayer) 
       )
       (setq name (vla-get-name obj)) 
       (setq blks (vla-item *BLK name))
       (vlax-for n blks
  (change-color n)  
       )
     )
     (vla-put-layer obj "0") 
   )
)

(defun Get_Layer_Status (*DOC / V_LIST L_LIST C_LIST T_LIST W_LIST)
   (vlax-for n (vla-get-layers *DOC)
     (setq V_List (cons (cons n (vla-get-LayerOn n)) V_List)
    L_List (cons (cons n (vla-get-Lock n)) L_List)
    C_List (cons (cons n (vla-get-TrueColor n)) C_List)
    T_List (cons (cons n (vla-get-Linetype n)) T_List)
    W_List (cons (cons n (vla-get-LineWeight n)) W_List)
    F_List (cons (cons n (vla-get-Freeze n)) F_List)
     )
   )
   (List V_List L_List C_List T_List W_List F_List)
)

(defun Restore_Layer_status (LayLst)
   (mapcar
     (function
       (lambda (x y)
  (foreach n X
    (if (/= (strcase (setq name (vla-get-name (car n))))
     (strcase (getvar "clayer"))
        )    
      (vlax-put-property (car n) y (cdr n))

      (if (/= y "Freeze") 
        (vlax-put-property (car n) y (cdr n))
      )
    )
  )
       )
     )
     LayLst
     (list "Layeron" "Lock" "TrueColor" "LineType" "LineWeight" "Freeze")
   )
)

(defun UnLock_All_Layers (*DOC)
   (vlax-for n (vla-get-layers *DOC)
     (vla-put-lock n :vlax-false)
   )
)

(defun UnFreeze_All_Layers (*DOC)
   (vlax-for n (vla-get-layers *DOC)
     (if (/= (strcase (vla-get-name n))
      (strcase (getvar "clayer"))
  )
       (vla-put-Freeze n :vlax-false)
     )
   )
)

This program will transfer all the graphics to the 0 layer, because only the 0 layer object color will change, other layers may not be able to change, I hope to help you.

[myloveflyer]

This Code is from Gilles Chanteau and maybe he will have a newer version.

Edit_bloc_3.0_eng.dcl Edit_bloc_3.0_eng.lsp

[jim78b]

OK THANKS

[jim78b]

EXCUSE ME BUT RTC.LSP DON'T WORK AS I THOUGHT i want set at start the reference point angle and then copy as many times as I want