See the top rated post in this thread. Click here

Results 1 to 7 of 7

Thread: Changes all the text color selected area (text, mtext, attdef, blk def.) skip lines and xref

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Member
    Join Date
    2010-01
    Posts
    18
    Login to Give a bone
    0

    Default Changes all the text color selected area (text, mtext, attdef, blk def.) skip lines and xref

    Can someone update the routine?
    The whole thing is a combination of a number of separate lisp routines that do work themselves.
    I have tried to summarize this in 1 routine.
    The routine now makes everything to 1 color, especially lines. That's a bit too much of a good thing.
    The point is that, of a selectable area in the drawing, only the color of text objects is changed. text, attdef, mtext and attributes. So also the text in blocks.
    Changes all the text color in selected block definitions to color 2.
    Combine the selection set to one function. Misappplied the color of all entities wil be changed, only text objects must be changed

    Code:
    (defun C:CHTXTINSELBLOCKSCOLOR2 (/ ent el s1 blk_name num nval antw atel atoff e1 e2 en tag nl en C SS K CBL BLK CBL2 C ACL ALY NLY EE NCL NEWE eset cntr enlist pt BLKDATA NEWCOLOR NEWLAYER XREFFLAG XDEPFLAG BLKENTNAME COUNT ENTDATA OLDCOLOR BLKENTNAME *ERROR* ERR-UBC LAY_NAME LT OLDERR)
    
    (graphscr)
    (setvar "cmdecho" 0)
    (command "_undo" "_m")
    (prompt "\nCOLOR-TEXT-OBJECTS-IN-SELECTED-BLOCKS-TO-COLOR-2.LSP - Versie 1.0")
    (prompt "\nAutoCAD lisp routine voor het selecteren en wijzigen in blocks van de kleur van alle text-objecten in AutoCAD kleur 2 geel")
    (prompt "\nBehandelt geen XREF & geneste blokken")
    (graphscr)
      (setvar "cmdecho" 0)
      (setvar "attreq" 0)
      (command "undo" "mark")
      (princ "\n\rSelekteer een block waarvan je de attributen kleur wilt aanpassen !")
      (if (setq ent (car (entsel "\n<Wijs een blok aan = Automatisch>  / Enter=handmatig  >>")))
       (progn
        (setq el (entget ent))
        (if (= (cdr (assoc 0 el)) "INSERT")
         (progn
          ;(setq s1 (ssget "x" (list (cons 2 (cdr (assoc 2 el))))))
          (setq blk_name (cdr (assoc 2 el)) lay_name (cdr (assoc 8 el)))
          (setq s1 (ssget "x" (list (cons 2 blk_name) (cons 8 lay_name))))
          (princ (strcat "\nSelekteren van alle blokken:" blk_name " op laag:"lay_name ))
    
         )
        )
       )
       ;else
       (progn (princ "\n\rSelekteer een blok >>")
        (setq s1 (ssget))
       )
      )
      (if s1
       (progn (setq num (1- (sslength s1)) atoff '())
       (terpri) (terpri)
       (initget 1 "J j N n")
       (setq nval (getstring "\nNieuwe Attribuut kleur NUMMER :"))
       (setq antw (getstring "\Alle attribuut kleuren aanpassen  [J/N]"))
      (if  (or (= antw "N") (= antw "n"))
       (progn (while (setq ent (car (nentsel "\nVan elke attributen moeten de kleuren aangepast worden...>>")))
      (setq atel (entget ent))
       (setq atoff (append atoff (list (cdr (assoc 2 atel))))) ) ) )
      (while  (/= num -1)
       (setq e1 (ssname s1 num))
       (setq e2 (entget e1))
       (if (and (=  (cdr (assoc 66 e2)) 1)
                (= (cdr (assoc 0 e2)) "INSERT")
           )
      (progn
       (prompt"\e[2J")
       (princ (strcat "\rOgenblikje... Nog " (itoa num) " blokken.... " ))
       (setq en (entnext e1) el (entget en))
       (while (/= (cdr (assoc 0 el)) "SEQEND")
        (if (and (member (setq tag (cdr (assoc 2 el))) atoff))
         (progn
    ;(setq nl (cons 40 nval) ol (assoc 40 el) el (subst nl ol el))
    ;(entmod el)
         (command  "attedit" "y" "" "" "" (cdr (car el)) "color" nval "")
         )
          (if (or (= antw "J") (= antw "j"))
           (progn
    ;(setq nl (cons 40 nval) ol (assoc 40 el) el (subst nl ol el))
    ;(entmod el)
           (command "attedit" "y" "" "" "" (cdr (car el)) "color" nval "")
           )
          )
        )
        (setq en (entnext en) el (entget en))
       )
       (entupd en)
       )
      )
      (setq num (1- num)) ) ) )
    
    (defun err-ubc (s)				; If an error (such as CTRL-C) occurs
    						; while this command is active...
    	(if (/= s "Function cancelled")
      		(princ (strcat "\nError: " s))
    	)
    	(setq *error* olderr)			; Restore old *error* handler
    	(princ)
    );err-ubc
    
    	(setq olderr *error* *error* err-ubc)
    	(initget "?")
            (while
    		(or (eq (setq C (getint "\nType nieuw kleur code/<?>: ")) "?")
    		    (null C)
    		    (> C 256)
    		    (< C 0)
    		);or
    		(textscr)
    		(princ "\n                                                           ")
    		(princ "\n                 Kleur code     |   Kleur omschrijving     ")
    		(princ "\n                ________________|_________________________ ")
    		(princ "\n                                |                          ")
    
    		(princ "\n                       2        |      GEEL - YELLOW       ")
    		(princ "\n                                               \n\n\n")
    		(initget "?")
    	);while
    
    		(prompt "\nSelecteer blokken om bij te werken. ")
    
    	(SETQ SS (SSGET '((0 . "INSERT"))))
    	(SETQ K 0)
    	(WHILE (< K (SSLENGTH SS))
            	(setq CBL (tblsearch "BLOCK" (CDR (ASSOC 2 (ENTGET (SETQ BLK (SSNAME SS K)))))))
            	(SETQ CBL2 (CDR (ASSOC -2 CBL)))
    		(WHILE (BOUNDP 'CBL2)
    			(SETQ EE (ENTGET CBL2))
    
    			;Update layer value
     			(SETQ NCL (CONS 62 C))
    			(SETQ ACL (ASSOC 62 EE))
    			(IF (= ACL nil)
    				(SETQ NEWE (APPEND EE (LIST NCL)))
    				(SETQ NEWE (SUBST NCL ACL EE))
    			);if
    			(ENTMOD NEWE)
    
    			(SETQ CBL2 (ENTNEXT CBL2))
    		);end while
    		(ENTUPD BLK)
    		(SETQ K (1+ K))
    	);end while
    	(setq *error* olderr)
    	(princ)
    ;)
    
    (setq eset
    (ssget
    (list
    (cons -4 "<OR")
    (cons 0 "MTEXT")
    (cons 0 "TEXT")
    (cons -4 "OR>")
    )
    )
    )
    (if (and eset (> (sslength eset) 0))
    (progn
    (setq cntr 0 lt (getvar "dimscale"))
    (while(< cntr (sslength eset))
    (setq en(ssname eset cntr))
    (setq enlist(entget en))
    (setq pt(cdr(assoc 10 enlist)))
    (grclear)
    (redraw)
    (grdraw pt (setq pt(polar pt 2.9671 (* lt 12.2080))) 90 -1)
    (grdraw pt (setq pt(polar pt 0.7854 (* lt 4.5020))) 90 -1)
    (grdraw pt (setq pt(polar pt 2.3562 (* lt 20.0000))) 90 -1)
    (grdraw pt (setq pt(polar pt 0.7854 (* lt 5.0000))) 90 -1)
    (grdraw pt (setq pt(polar pt 5.4978 (* lt 20.0000))) 90 -1)
    (grdraw pt (setq pt(polar pt 0.7854 (* lt 4.5020))) 90 -1)
    (grdraw pt (setq pt(polar pt 4.8869 (* lt 12.2080))) 90 -1)
    (command "CHANGE" en "" "Properties" "Color" "2" "")
    (grdraw pt (setq pt(polar pt 2.9671 (* lt 12.2080))) 90 -1)
    (grdraw pt (setq pt(polar pt 0.7854 (* lt 4.5020))) 90 -1)
    (grdraw pt (setq pt(polar pt 2.3562 (* lt 20.0000))) 90 -1)
    (grdraw pt (setq pt(polar pt 0.7854 (* lt 5.0000))) 90 -1)
    (grdraw pt (setq pt(polar pt 5.4978 (* lt 20.0000))) 90 -1)
    (grdraw pt (setq pt(polar pt 0.7854 (* lt 4.5020))) 90 -1)
    (grdraw pt (setq pt(polar pt 4.8869 (* lt 12.2080))) 90 -1)
    (setq cntr(+ cntr 1))
    )
    )
    )
    (alert (strcat "Aantal gewijzigde text-veld-objecten en/of Mtext-veld-objecten: " (itoa cntr) "."))
    (grclear)
    (redraw)
    
    (command ".undo" "group")
       (setq BLKDATA (tblnext "BLOCK" t))
       (setq NEWCOLOR (cons 62 2))  ;this will set 62 (color) to 2
    ;   (setq NEWLAYER (cons 8 "0"))  ;this will set 8 (layer) to 0
       ; While there is an entry in the block table to process, continue
       (while BLKDATA
          (prompt "\nRedefining colors for block: ")
          (princ (cdr (assoc 2 BLKDATA)))
          ; Check to see if block is an XREF or is XREF dependent
          (setq XREFFLAG (assoc 1 BLKDATA))
          (setq XDEPFLAG (cdr (assoc 70 BLKDATA)))
          ; If block is not XREF or XREF dependent, i.e., regular block, then proceed.
          (if (and (not XREFFLAG) (/= (logand XDEPFLAG 32) 32))
             (progn
                (setq BLKENTNAME (cdr (assoc -2 BLKDATA)))
                (setq COUNT 1)
                (terpri)
                (while BLKENTNAME
                   (princ COUNT)
                   (princ "\r")
                   (setq ENTDATA (entget BLKENTNAME)); get entities data 
                   (setq OLDCOLOR (assoc 62 ENTDATA))  ;get entities old color value
                   (if OLDCOLOR                         ; if value exist (null = bylayer)
                      (entmod (subst newcolor oldcolor ENTDATA)) ; substitute old color to byblock
                      (entmod (cons newcolor ENTDATA))      ; modify ent data w/ byblock values
                   )
                   (setq BLKENTNAME (entnext BLKENTNAME)) ;if attributes exist, then edit next one
                   (setq COUNT (+ COUNT 1));
                ) ;end while for attribute trap
             ) ;progn
             (progn
                (princ "    XREF...skipping!")
             ) ;progn
          );end if not an Xref
          (setq BLKDATA (tblnext "BLOCK")) ;next block please
       ) ;end while loop of blk data available to edit
    (command ".undo" "end")
    (command ".regen")
    (setvar "cmdecho" 1)
    (prompt "\nDe AutoCAD-selecteren-en-wijzigen-van-de-kleur-van-text-objecten-in-blocks-naar-AutoCAD-kleur-2-geel-routine opdracht is be£indigd, er zijn geen objecten meer geselecteerd. Start de routine opnieuw met AutoCAD commando: CHTXTINSELBLOCKSCOLOR2")
    (princ)
    )
    The routine makes everything to 1 color, even lines and polylines. That's a bit too much of a good thing.
    The point is that, of a selectable area in the drawing, only the color of text objects is changed. text, attdef, mtext, attributes and text in blocks
    Last edited by Opie; 2022-08-25 at 12:49 PM. Reason: [code] tags added

Similar Threads

  1. BLOCKS, ATTDEF, AND SCALES...
    By gisdude in forum CAD Management - General
    Replies: 2
    Last Post: 2015-05-18, 04:24 PM
  2. Replies: 1
    Last Post: 2014-08-08, 05:20 PM
  3. Fields in ttl blk connected to SSM
    By cadman_meg in forum AutoCAD Fields
    Replies: 3
    Last Post: 2008-02-14, 04:33 PM
  4. Option to Skip Update for All Tables
    By autocad.wishlist1734 in forum AutoCAD Wish List
    Replies: 0
    Last Post: 2007-06-21, 04:48 PM
  5. Out of Date Table: Update All / Skip Update
    By .chad in forum ACA Wish List
    Replies: 2
    Last Post: 2007-06-08, 01:33 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •