[编程交流] 要更改的AutoCAD Lisp例程

(defun C:CHANGESTYLE (/ entities len count ent ent_data ent_name new_style_name)
(command "STYLE" "Company_Name" "Arial Narrow.ttf" "" "" "" "" "")
(setq entities (ssget "x" '((0 . "attdef")))
     len      (sslength entities)
     count 0
);setq 
(while (< count len)
      (setq ent      (ssname entities count) 
            ent_data (entget ent)
            ent_name (cdr (assoc 7 ent_data))
      );setq
(setq new_style_name (cons 7 "Company_Name"))
(setq ent_data (subst new_style_name (assoc 7 ent_data) ent_data))
(entmod ent_data)
(setq count (+ count 1))
);while
(princ)
);defun

(defun c:changestyle  (/ entities len count ent ent_data ent_name new_style_name)
 (command "STYLE" "Company_Name" "Arial Narrow.ttf" "" "" "" "" "")
 (if (setq entities (ssget "x" '((0 . "attdef"))))
   (progn
     (setq len (sslength entities) count 0)
     (while (< count len)
       (setq ent (ssname entities count) ent_data (entget ent) ent_name (cdr (assoc 7 ent_data))
               new_style_name (cons 7 "Company_Name") ent_data (subst new_style_name (assoc 7 ent_data) ent_data))
       (entmod ent_data) (setq count (+ count 1))))
   (princ "\nNo valid objects (ATTDEF) found in this drawing")
 )
 (princ)
)

(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vlax-for blk (vla-get-blocks doc)
(princ (strcat "\n " (vla-get-name blk)))
; check hasattributes
; go inside block and look at "Items"
; change stylename
)

Your Code Here[/NOPARSE]

Your Code Here

; change text style - written by rlx 2 feb 2018 for Lawrst on CadTutor
; uses odbx to process entire folder , type 'cts' on commandline to start program
(defun c:cts (/ err acapp actdoc actspace acdocs all-open objdbx sf dwg-list start) (_init) (_exit) (terpri) (princ))
(defun change_text_style  ( $dwg / odbxdoc acstyles style-obj fnt layout obj o-name bn bn-list ent)
 (if (and (setq odbxdoc (odbx_open $dwg)) (setq acstyles (vla-get-textstyles odbxdoc))
   (setq style-obj (vla-add acstyles "Company_Name")) (setq fnt (findfile "C:\\Windows\\Fonts\\arialn.ttf")))
   (progn
     (vla-put-fontfile style-obj fnt)
     (vlax-for layout (vla-get-layouts odbxdoc)
       (vlax-for obj (vla-get-block layout)
         (cond
           ; remove "AcDbText" "AcDbMText" to NOT update (m)text's
           ((member (vla-get-objectname obj) '("AcDbText" "AcDbMText" "AcDbAttributeDefinition"))
            (vla-put-StyleName obj "Company_Name"))
           ((= (vla-get-objectname obj) "AcDbBlockReference")
            (mapcar '(lambda(x) (vla-put-StyleName x "Company_Name")) (get-block-ent obj)))
         )
       )
     )
     (vl-catch-all-error-p (vl-catch-all-apply 'vla-saveas (list odbxdoc $dwg)))
   )
 )
)
(defun get-block-ent ( b / bn lst block ent)
 (setq bn (vla-Get-EffectiveName b))
 ;;; get attributes
 (if (eq :vlax-true (vla-get-HasAttributes b))(setq lst (vlax-invoke b 'GetAttributes)))
 ;;; get text entities - just remove next 4 lines to NOT update (m)text
 (vlax-for block (vla-get-Blocks odbxdoc)
   (if (eq (vla-get-name block) bn)
     (vlax-for ent block (if (member (vla-get-objectname ent) '("AcDbText" "AcDbMText")) (setq lst (cons ent lst)))))
 )
 lst
)
 
;--- Init ----------------------------------------------- Begin of Init section -------------------------------------------------- Init ---
(defun _init  ()
 (vl-load-com)
 (setq err *error*)
 (defun *error* (s) (princ s) (_exit))
 (defun _exit () (odbx_releaseall) (setq *error* err))
 (odbx_init)
 (if (and (setq sf (getfolder "Select source folder for drawings")) (vl-consp (setq dwg-list (fido sf))))
   (progn (setq start (car (_vl-times)))
   (princ (strcat "\nProcessing " (setq l (itoa (length dwg-list))) " drawings..."))
   (foreach dwg dwg-list (change_text_style dwg))
   (princ (strcat "\n\nProcessed " l " drawings in " (rtos (/ (- (car (_vl-times)) start) 1000.) 2 4) " secs.")))
   (princ "\nNo files to process...")
 )
)
;--- Init ------------------------------------------------ End of Init section --------------------------------------------------- Init ---
;--- Scripting Object --------------------------------- Begin of Scripting Object ------------------------------------ Scripting Object ---
; Thanks to TonyT - just compressed and tweaked it a little bit
(defun load_fso_scripting  (/ server fso:progid fso:prefix)
 (setq fso:progid "Scripting.FileSystemObject" fso:prefix "wsh-")
 (if (not wsh-get-drives)
   (if (not (setq server (cogetclassserver fso:progid))) (alert "Error: Windows Scripting Host is not installed")
     (vlax-import-type-library :tlb-filename server :methods-prefix fso:prefix :properties-prefix fso:prefix :constants-prefix
(strcat ":" fso:prefix)))))
(defun progid->clsid (progid) (vl-registry-read (strcat "HKEY_CLASSES_ROOT\" progid "[url="file://\\CLSID"]\\CLSID[/url]")))
(defun cogetclassserver (progid) (cogetclassproperty progid "InprocServer32"))
(defun cogetclassproperty  (progid property / clsid)
 (if (setq clsid (progid->clsid progid)) (vl-registry-read (strcat "HKEY_CLASSES_ROOT\\CLSID\" clsid "\" property))))
; Find Drawing Objects - test : (setq lst (fido (dos_path "c:/temp/lisp"))) works also with networkpaths
(defun fido  ($f / fso fld rslt)
 (load_fso_scripting) (setq fso (vla-getinterfaceobject (vlax-get-acad-object) "Scripting.FileSystemObject"))
 (setq fld  (wsh-getfolder fso $f) rslt (fifo fld "*.dwg"))(vlax-release-object fld)(vlax-release-object fso)  rslt)
; find in folders fl=file ,fls=files, sf=subfolder, sfl=subfolderlist, res=result
(defun fifo  (%dir %ext / fl fls sf sfl res)
 (vlax-for fl (setq fls (wsh-get-files %dir))
   (if (wcmatch (strcase (wsh-get-name fl) t) %ext) (setq res (cons (wsh-get-path fl) res)))(vlax-release-object fl))
 (vlax-release-object fls)
 (vlax-for sf (setq sfl (wsh-get-subfolders %dir)) (setq res (append res (fifo sf %ext)))(vlax-release-object sf))
 (release_me (list sfl)) res)
;--- Scripting Object ---------------------------------- End of Scripting Object ------------------------------------- Scripting Object ---
;--- Odbx ------------------------------------------------- Begin Odbx Section --------------------------------------------------- Odbx ---
(defun odbx_init  (/ acver)
 (setq acapp (vlax-get-acad-object) actdoc (vla-get-activedocument acapp) actspace (vla-get-modelspace actdoc)
acdocs (vla-get-documents acapp) acver (atoi (getvar "ACADVER"))
all-open (vlax-for dwg acdocs (setq all-open (cons (strcase (vla-get-fullname dwg)) all-open)))
objdbx (vl-catch-all-apply 'vla-getinterfaceobject
  (list acapp (if (< acver 16) "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa acver))))))
 (if (or (void objdbx) (vl-catch-all-error-p objdbx)) (setq objdbx nil)))
(defun odbx_releaseall ()
 (mapcar '(lambda (x) (if (and (= 'vla-object (type x)) (not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil))
   (list odbxdoc acdocs objdbx actspace actdoc acapp)) (gc))
(defun odbx_open  (dwg)
 (if objdbx (if (member (strcase dwg) all-open)
       (odbx_open_copy (findfile dwg))(vl-catch-all-apply 'vla-open (list objdbx (findfile dwg))))) objdbx)
(defun odbx_open_copy  (dwg / copy)
 (vl-file-copy (findfile dwg) (setq copy (vl-filename-mktemp nil nil ".dwg")))(vla-open objdbx (findfile copy))  objdbx)
;--- Odbx -------------------------------------------------- End Odbx Section ---------------------------------------------------- Odbx ---
;--- + + + --------------------------------------------- Begin of tiny lisp section --------------------------------------------- + + + ---
(defun wait  (sec / stop) (setq stop (+ (getvar "DATE") (/ sec 86400.0))) (while (> stop (getvar "DATE"))))
(defun void  (x) (if (member x (list "" " " "  " "   " "       " nil '())) t nil))
(defun e2v (e)(vlax-ename->vla-object e)) ;||; (defun v2e (o)(vlax-vla-object->ename o)) ;||; (defun _type (e)(cdr (assoc 0 (entget e))))
(defun release_me  (lst)
 (mapcar '(lambda (x)(if (and (= 'vla-object (type x))(not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil)) lst))
(defun getfolder  (msg / fl sh)
 (if (and (setq sh (vlax-create-object "Shell.Application"))(setq fl (vlax-invoke sh 'browseforfolder 0 msg 0 "")))
   (setq fl (vlax-get-property (vlax-get-property fl 'self) 'path))(setq fl nil))(release_me (list sh)) fl)
(defun get_block_name (b)
 (cond ((vlax-property-available-p b 'effectivename) (vla-get-effectivename b)) ((vlax-property-available-p b 'name) (vla-get-name b))))
; make sure path is corect for scripting object (dos_path (strcat (getvar "dwgprefix") (getvar "dwgname")))
(defun dos_path  ($p) (if (= (type $p) 'str) (strcase (vl-string-translate "/" "\" $p)) ""))
;--- + + + ---------------------------------------------- End of tiny lisp section ---------------------------------------------- + + + ---
(princ "\nRlx 2 feb 2018 : Type 'CTS' on commandline to start program\n")
(princ)