LISP for command routines

[yu85.info]

Hi, I have a routine of certain  commands I an using constantly. Is there a way please to make a LISP to run this commands without the need to choose the objects and put the input manually?

This is the set of commands:

1. SETBYLAYER for all objects in drawing --> Y---Y

2. ATTSYNC for all blocks in drawing --> select by name ---> *

3. select all blocks in drawing and change scale X to --> 1

4. select all blocks in drawing and do ROUNDT [a command I have for a LISP] --> -2 [input]

Thanks very very much in advance

[Moshe-A]

@yu85.info  hi,

check this one, do not know what ROUNDT is?

engoy

Moshe

(defun c:prepMyDwg (/ ss ename elist)
 (setvar "cmdecho" 0)
 (command "._undo" "_begin")
 
 (command "._setbylayer" "_si" "_all" "_Yes" "_Yes")
 (command "._attsync" "_name" "*")

 (if (setq ss (ssget "_x" '((0 . "insert"))))
  (foreach ename (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
   (setq elist (entget ename))

   (foreach cod '(41 42 43)
    (setq elist (subst (cons cod 1.0) (assoc cod elist) elist))
   )

   (entmod elist)
  ); foreach
 ); if

 (command "._undo" "_end")
 (setvar "cmdecho" 1)
 (princ)
)

[yu85.info]

Dear sir, thanks very much. Forgive my rudeness but just 2 more things.

1. Changing block scale to 1 did not work. Print screen attached.

2. The ROUNDT command is a LISP, VLX file also attached as ZIP

Thanks again sir

[Moshe-A]

@yu85.info ,

Here is an update, if the scale does not work, share your dwg.

Moshe

(defun c:prepMyDwg (/ isNumeric ; local function
		      ss ename elist AcDbBlkRef AcDbAttrib value)
  
 ; return T if s is pure numeric otherwise nil
 (defun isNumeric (s)
  (vl-every 
   '(lambda (n)
     (or
      (member n '(37 43 45 46 112))
      (and (>= n 48) (<= n 57))
     )
    ); lambda
    (vl-string->list s) 
  ); vl-every
 ); isNumeric

  
 (setvar "cmdecho" 0)
 (command "._undo" "_begin")

 (if (setq ss (ssget "_x" '((0 . "insert"))))
  (foreach ename (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
   (setq elist (entget ename))

   (foreach cod '(41 42 43)
    (setq elist (subst (cons cod 1.0) (assoc cod elist) elist))
   )

   (entmod elist)

   (setq AcDbBlkRef (vlax-ename->vla-object ename))
   (foreach AcDbAttrib (vlax-invoke AcDbBlkRef 'GetAttributes)
    (setq value (vla-get-textString AcDbAttrib))

    (if (isNumeric value)
     (vla-put-textString AcDbAttrib (rtos (atof value) 2 2))
    )
     
    (vlax-release-object AcDbAttrib)
   ); foreach
    
   (vlax-release-object AcDbBlkRef)
  ); foreach
 ); if

 (command "._setbylayer" "_si" "_all" "_Yes" "_Yes")
 (command "._attsync" "_name" "*")

 (command "._undo" "_end")
 (setvar "cmdecho" 1)
 (princ)
)

[yu85.info]

Thanks! I really appreciate your help sir.

For some reason the scale does not change and also the ROUNDT command does not work

(The purpose of ROUNDT is simply to edit the value of the attribute to be in a format of decimal number with two numbers after the point [21.1 --->21.10]

 I attached a DWG file with the objects I need to edit with all the commands I wrote earlier.

Thank you very much for your kindly help

[MrJSmith · Accepted solution]

Here is my attempt.

(defun c:PrepMyDwg ( / text blks roundto roundm RegExMatchCapture *REX* setRegexObj getAtts setUniqueAttibuteTagsDefinition idc_FB_UpdAttribs fixBlockName All2BL ssList removeDuplicates)
	;################## Support Functions ###########################
	(defun removeDuplicates ( l ) ;; Unique  -  Lee Mac ;; Returns a list with duplicate elements removed.
		(if l (cons (car l) (removeDuplicates (vl-remove (car l) (cdr l)))))
	)
	(defun ssList (ss / lst ct)
		(if ss
			(progn
				(setq ct 0)
				(repeat (sslength ss)
					(setq 
						lst (cons (ssname ss ct) lst)
						ct (+ ct 1)
					)
				)
			)
		)
		lst
	) 
	(defun All2BL (/ colorObj n) ;Sets everything to by layer including leaders
		(setq n 0)
		(vlax-for block (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
			(vlax-for obj block
				(cond 
					((wcmatch (vla-get-objectname obj) "AcDb*Dimension,AcDbLeader")
						(setq n (1+ n))
						(foreach prop '(Color DimensionLineColor ExtensionLineColor TextColor)
							(vl-catch-all-apply 'vlax-put-property (list obj prop acbylayer))
						)
					)
					((wcmatch (vla-get-objectname obj) "AcDbMLeader")
						(setq n (1+ n))
						(setq colorObj (vlax-get-property obj 'LeaderLineColor))
						(vla-put-ColorMethod colorObj 192)
						(vlax-put-property obj 'LeaderLineColor colorObj)
						(vl-catch-all-apply 'vla-put-color (list obj acbylayer))
					)
					(T
						(setq n (1+ n))
						(vl-catch-all-apply 'vla-put-color (list obj acbylayer))
					)
				)
				
			)
		)
		(princ (strcat "\nProcessed: " (itoa n) " items to by layer."))
		(princ)
	)
	
	(defun fixBlockName (blockName /            
                   sBlockName ; Block name
                   lBlockData ; Entity data
                   eSubEntity ; Sub-entity name
                   lSubData ; Sub-entity data
                   iCount ; Counter
                  )

		;; Get block from user and make sure it's an INSERT type
		(setq sBlockName blockName)
			 
		;; Get block info from the block table
		(setq
		lBlockData (tblsearch "BLOCK" sBlockName)
		eSubEntity (cdr (assoc -2 lBlockData))
		) ;_ end setq

		;; Make sure block is not an Xref
		(if (not (assoc 1 lBlockData))
			(progn
			  ;(princ "\nProcessing block: ")
			  ;(princ sBlockName)

			  ;(princ "\nUpdating blocks sub-entities. . .")

			  ;; Parse through all of the blocks sub-entities

			  (while eSubEntity
				;(princ " .")
				(setq lSubData (entget eSubEntity))
				;; Update layer property

				(if (assoc 8 lSubData)
					(progn
						(setq lSubData (subst (cons 8 "0") (assoc 8 lSubData) lSubData))
						(entmod lSubData)
					) ;_ end progn
				) ;_ end if

				;; Update the linetype property

				(if (assoc 6 lSubData)
				  (progn
					(setq lSubData
						   (subst
							 (cons 6 "BYBLOCK")
							 (assoc 6 lSubData)
							 lSubData
						   ) ;_ end subst
					) ;_ end setq
					(entmod lSubData)
				  ) ;_ end progn
				  (entmod (append lSubData (list (cons 6 "BYBLOCK"))))
				) ;_ end if

				;; Update the color property

				(if (assoc 62 lSubData)
					(progn
						(setq lSubData
							(subst
								(cons 62 0)
								(assoc 62 lSubData)
								lSubData
							) ;_ end subst
						) ;_ end setq
						(entmod lSubData)
					) ;_ end progn
					(entmod (append lSubData (list (cons 62 0))))
				) ;_ end if
				; get next sub entity
				(if (= (cdr (assoc 0 lSubData)) "INSERT")
					(fixBlockName (cdr (assoc 2 lSubData)))
				)
				(setq eSubEntity (entnext eSubEntity))
			) ; end while

			;; Update attributes

			(idc_FB_UpdAttribs)
			) ; end progn
			;(print "XREF selected. Not updated!")
		  ) ; end if
	)   ; end defun

		;*******************************************************************************
		; Function to update block attributes
		;*******************************************************************************
	(defun idc_FB_UpdAttribs ()

	  ;; Update any attribute definitions

	  (setq iCount 0)

	  ;(princ "\nUpdating attributes. . .")
	  (if (setq ssInserts (ssget "x"
								 (list (cons 0 "INSERT")
									   (cons 66 1)
									   (cons 2 sBlockName)
								 ) ;_ end list
						  ) ;_ end ssget
		  ) ;_ end setq
		(repeat (sslength ssInserts)

		  (setq eBlockName (ssname ssInserts iCount))

		  (if (setq eSubEntity (entnext eBlockName))
			(setq
			  lSubData (entget eSubEntity)
			  eSubType (cdr (assoc 0 lSubData))
			) ;_ end setq
		  ) ;_ end if

		  (while (or (= eSubType "ATTRIB") (= eSubType "SEQEND"))

			;; Update layer property

			(if (assoc 8 lSubData)
			  (progn
				(setq lSubData
					   (subst
						 (cons 8 "0")
						 (assoc 8 lSubData)
						 lSubData
					   ) ;_ end subst
				) ;_ end setq
				(entmod lSubData)
			  ) ;_ end progn
			) ;_ end if

			;; Update the linetype property

			(if (assoc 6 lSubData)
			  (progn
				(setq lSubData
					   (subst
						 (cons 6 "BYBLOCK")
						 (assoc 6 lSubData)
						 lSubData
					   ) ;_ end subst
				) ;_ end setq
				(entmod lSubData)
			  ) ;_ end progn
			  (entmod (append lSubData (list (cons 6 "BYBLOCK"))))
			) ;_ end if

			;; Update the color property

			(if (assoc 62 lSubData)
			  (progn
				(setq lSubData
					   (subst
						 (cons 62 0)
						 (assoc 62 lSubData)
						 lSubData
					   ) ;_ end subst
				) ;_ end setq
				(entmod lSubData)
			  ) ;_ end progn
			  (entmod (append lSubData (list (cons 62 0))))
			) ;_ end if

			(if (setq eSubEntity (entnext eSubEntity))
			  (setq
				lSubData (entget eSubEntity)
				eSubType (cdr (assoc 0 lSubData))
			  ) ;_ end setq
			  (setq eSubType nil)
			) ;_ end if

		  ) ; end while

		  (setq iCount (1+ iCount))

		) ; end repeat

	  ) ; end if
	)   ; end defun
	
	;Ensures all the attribute tags in a attributed block are unique
	(defun setUniqueAttibuteTagsDefinition (BlkName / tag tagList ct vlaGetItem) ; 
		(defun vlaGetItem ( col itm ) 
			(if (not (vl-catch-all-error-p (setq itm (vl-catch-all-apply 'vla-item (list col itm)))))
				itm
			)
		)
		(vlax-for obj (vlaGetItem (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))) BlkName)
			(if (= (vla-get-objectname obj) "AcDbAttributeDefinition")
				(progn
					(setq att obj)
					(setq tag (vla-get-tagstring att))
					(if (not (assoc tag tagList))
						(setq tagList (append tagList (list (cons tag 1)))) ;New tag, add it to list
						(progn
							(setq ct (cdr (assoc tag tagList))) ;Get current list count
							(vla-put-tagstring att (strcat tag (itoa ct))) ;Change TagName with count
							(setq tagList (subst (cons tag (+ ct 1)) (cons tag ct) tagList)) ;Update count list with +1
						)
					)
				)
			)
		)
	)
		
	(defun getAtts (o)
		(if 
			(and
				(= "AcDbBlockReference" (vla-get-objectname o)) ;Make sure o is a block
				(= :vlax-true (vla-get-hasattributes o)) ;Make sure it has Attrs
			)
			(mapcar '(lambda (x) (cons (vla-get-tagstring x) (vla-get-textstring x))) (vlax-invoke o 'getattributes)) ;Return attributes in a cons list
		)
	)
	
	(defun setRegexObj ()
		(if(not (or *REX* (setq *REX* (vlax-create-object "VBScript.RegExp"))))(alert "Please restart your AutoCAD. Session is corrupted. Commands may not work."))
	)
	
	(defun RegExMatchCapture ( pat string / lst ) ;Returns only the matches of the capture group "( )" in a list 
		(vlax-put    *REX* 'Pattern pat)
		(vlax-put   *REX* 'Global actrue)
		(vlax-put    *REX* 'IgnoreCase acfalse)
		(vlax-for x  (vlax-invoke *REX* 'Execute string)
			(vlax-for y (vlax-get x 'SubMatches)
				(setq lst (append lst (list y)))
			)
		)
		lst
	)
	(defun roundm ( n m ) (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5))) ) ;; Rounds 'n' to the nearest multiple of 'm'
	(defun roundto ( n p ) (roundm n (expt 10.0 (- p)))) ;; Rounds 'n' to 'p' decimal places
	
	;#################### Main Functions ###########################
	(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	;Set All Objects To ByLayer 
	(All2BL) 
	;Set all the blocks to layer 0 otherwise they won't be by layer
	(setq blks (sslist (ssget "_X" '((0 . "INSERT")))))
	(foreach it (removeDuplicates (mapcar '(lambda (x) (cdr (assoc 2 (entget x)))) blks))
		(fixBlockName it)
		(setUniqueAttibuteTagsDefinition it)
	)
	
	;Sync all Attrs
	(command "._attsync" "_name" "*")

	;Scale all Blocks to 1 & Round their attributes
	(setRegexObj)
	(foreach it (mapcar 'vlax-ename->vla-object blks)
		;Scale all Blocks to 1
		(vla-put-XScaleFactor it 1.0)
		(vla-put-XEffectiveScaleFactor it 1.0)
		(vla-put-YScaleFactor it 1.0)
		(vla-put-YEffectiveScaleFactor it 1.0)
		(vla-put-ZScaleFactor it 1.0)
		(vla-put-ZEffectiveScaleFactor it 1.0)
		
		;Round All Attributes To 2 Decimals
		(if 
			(and
				(= "AcDbBlockReference" (vla-get-objectname it)) ;Make sure it is a block
				(= :vlax-true (vla-get-hasattributes it)) ;Make sure it has Attrs
			)
			(foreach attr (vlax-invoke it 'getattributes)
				(setq text (vla-get-textstring attr))

				;Round numbers with 2 or more decimals to 2 decimal places
				(foreach match (RegExMatchCapture "(\\d+\\.\\d{2,})" text)
					(setq text (vl-string-subst (rtos (roundto (atof match) 2) 2 2) match text))
				) 
				
				;Add zeros to numbers with only 1 decimal
				(foreach match (RegExMatchCapture "(\\d\\.\\d(?!\\d))" text)
					 (setq text (vl-string-subst (strcat match "0") match text)) 				 
				)
				
				(vla-put-textstring attr text)
			)
			
		)
	)
	(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
	(vlax-release-object *REX*)
	(print "Drawing has been prepped.")
	(princ)
)

[Moshe-A · Accepted solution]

@yu85.info ,

have an update.

Here is my conclusion after exploring your dwg:

1. your drawing is in Metres and block TASHTIT is in Feet - better sync them

2. TASHTIT is defined with Scale uniformly enabled, meaning block scale is X=Y=Z always.

3. are you aware that the block can not be explode, that's of course does not limit you to scale the block.

fix 1 and the lisp will work like a charm 😄

Moshe

(defun c:prepMyDwg (/ isNumeric DisableUniformScale ; local functions
		      adoc savDimzin ss ename elist AcDbBlkRef AcDbAttrib value)
 
 ; return T if s is pure numeric otherwise nil
 (defun isNumeric (s)
  (vl-every 
   '(lambda (n)
     (or
      (member n '(37 43 45 46 112))
      (and (>= n 48) (<= n 57))
     )
    ); lambda
    (vl-string->list s) 
  ); vl-every
 ); isNumeric

 (setvar "cmdecho" 0)
 (command "._undo" "_begin")

 (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
 (setq saveDimzin (vla-getVariable adoc "dimzin"))
 (vla-setVariable adoc "dimzin" 8)

 (if (setq ss (ssget "_x" '((0 . "insert"))))
  (foreach ename (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
   (setq elist (entget ename))

   (foreach cod '(41 42 43)
    (setq elist (subst (cons cod 1.0) (assoc cod elist) elist))
   )

   (entmod elist)
    
   (foreach AcDbAttrib (vlax-invoke AcDbBlkRef 'GetAttributes)
    (setq value (vla-get-textString AcDbAttrib))

    (if (isNumeric value)
     (vla-put-textString AcDbAttrib (rtos (atof value) 2 2))
    )
     
    (vlax-release-object AcDbAttrib)
   ); foreach
    
   (vlax-release-object AcDbBlkRef)
  ); foreach
 ); if

 (command "._setbylayer" "_si" "_all" "_Yes" "_Yes")
 (command "._attsync" "_name" "*")

 (vl-catch-all-apply 'vla-setVariable (list adoc "dimzin" savDimzin))
 (vlax-release-object adoc)
  
 (command "._undo" "_end")
 (setvar "cmdecho" 1)
 (princ)
)

[yu85.info]

Incredible!

Thanks you so much for your help sir

[yu85.info]

Just perfect!

Thank you for your precious time sir