[LISP程序]：批量处理多图档图形文件程序诸例

lsjjm

批量处理多图档图形文件程序诸例
[php]
批量处理多图档图形文件程序诸例
(vl-load-com)
; 1.修改多图形文件指定层名
(defun changelayer ();;change the layer name for all dwgs
  (setq olay (getstring "\nEnter Old Layer Name : "))
  (setq nlay (getstring "\nEnter New Layer Name : "))
  (vlax-for i (vla-get-Documents (vlax-get-acad-object))
   (setq lays (vla-get-layers i))
   (vla-put-name (vla-item lays olay) nlay)
  )
)
; 2.指定目录下的图形文件名加前缀
(defun addprefixdegs () ;;add prefix on dwgname of specified directory
  (setq dir (getstring "Input Directory: "))
  (setq ff (vl-directory-files dir "*.dwg" 1))
  (foreach i ff
    (vl-file-rename i (strcat "parker" i))
  )
)
; 3.修改指定目录下的图形文件名
(defun renamedwgs () ;;rename dwgs of specified directory
  (setq dir (getstring "Input Directory: "))
  (setq ff (vl-directory-files dir "*.dwg" 1))
  (foreach i ff
    (if (= (substr i 1 2) "lx")
      (vl-file-rename i (vl-string-subst "parker" "lx" i))
    )
  )
)
; 4.打开指定表中所有图形文件
(defun opendwgs (dwglst)  ;;open all drawing of list
  (foreach i dwglst
    (vla-open
      (vla-get-documents
        (vlax-get-acad-object))(findfile i))
  )
)
; 5.关闭所有打开的图形文件
(defun closedwgs () ;;close all opened drawings
  (vlax-for Item (vla-get-Documents (vlax-get-acad-object))
    (if (= (vla-get-Active Item) :vlax-False)
      (vla-close Item :vlax-true)
      (vla-SendCommand Item "_.close\n")
    )
  )
)
; 6.关闭除当前之外所有打开的图形文件
(defun closeotherdwgs () ;;cloas all other opened drawings
  (setq cad (vlax-get-acad-object))
  (setq this (vla-get-activedocument cad))
  (vlax-for i (vla-get-Documents cad)
    (if (/= (vla-get-name this)(vla-get-name i))
      (vla-close i :vlax-true)
    )
  )
)
; 7.清理, 检查, 存盘所有打开的图形文件
(defun pasdwgs () ;;purge,audit and save all opened drawings
  (vlax-for i (vla-get-Documents (vlax-get-acad-object))
    (vla-purgeall i)
    (vla-auditinfo i t)
    (vla-save i)
  )
)
; 8.修改所有图形文件指定标志的属性
(defun changeattfortag () ;;change attribute for specified tag
   (vlax-for i (vla-get-Documents (vlax-get-acad-object))
    (vlax-for j (vla-get-paperspace i)
      (if (= (vla-get-objectname j) "AcDbBlockReference")
        (vla-put-textstring (vlax-ename->vla-object
                              (last (assoc "T2" (getattributes j)))) "AAA")          
      
      )
    )
    (vla-regen i acallviewports)
  )
)
(defun getattributes (obj / lst)   
  (if (safearray-value
    (setq lst (vlax-variant-value (vla-getattributes obj))))
    (mapcar '(lambda (x) (list (vla-get-tagstring x)
                               (vla-get-textstring x)
                               (vlax-vla-object->ename x)))
             (vlax-safearray->list lst))
  )
)
; 9.修改所有图形文件的DIMSCALE
(defun changedimscale () ;;change DIMSCALE for all drwaings
  (setq nds (getreal "New Dimscale: "))
  (vlax-for item (vla-get-Documents (vlax-get-acad-object))
    (vla-setVariable
      (vla-get-document
        (vla-get-modelspace item)) "dimscale" nds)
  )
)
; 10.在所有图形文件中建立新图层
(defun createnewlayer ();; create new layer in all dwgs
  (setq layname (getstring "\n Input the Name of Layer: "))
  (setq col (getstring "\nColor Number: "))
  (setq lty (getstring "\nLinetype<Continuous>: "))
  (if (= lty "")(setq lty "Continuous"))
  (vlax-for i (vla-get-Documents (vlax-get-acad-object))
    (if (vl-catch-all-error-p
          (setq
            olayer
            (vl-catch-all-apply 'vla-add
              (list (vla-get-layers i) layname)
            )
          )
        )
      nil
      (cond (olayer (vla-put-color olayer col)(vla-put-linetype olayer lty)))
    )
  )
)
; 11.修改所有图形文件的文本所在图层的层名
(defun changelayeroftext () ;;change layer of text for all drwings
  (setq e (car (entsel)))
  (setq lay (vla-get-layer (vlax-ename->vla-object e)))
  (vlax-for i (vla-get-Documents (vlax-get-acad-object))
    (vlax-for j (vla-get-modelspace i)
      (if (= "AcDbText" (vla-get-objectname j))
        (vla-put-layer j lay)
    )
    (vla-regen i acallviewports)
  )
)
; 12.修改所有图形文件的文本的高度
(defun cgangetextheigh () ;;change text heigh for all drawibgs
  (setq th (getreal "\nNew Text Height: "))
  (vlax-for i (vla-get-Documents (vlax-get-acad-object))
    (vlax-for j (vla-get-modelspace i)
      (if (= "AcDbText" (vla-get-objectname j))
        (vla-put-height j th)
      )
    )
    (vla-regen i acallviewports)
  )
)
;13. 在所有图形文件创建实体
(defun createentity () ;; create a circle in all dwgs
  (setq doc (vla-get-Documents (vlax-get-acad-object)))
  (setq  pc '(5 5))
  (setq   r 0.8)
  (vlax-for i doc
    (setq ms (vla-get-modelspace i))
    (vla-addcircle ms (vlax-3d-point pc) r)
  )  
)
;14. 拷贝当前图形文件实体到其它所有图形
(defun copyobjtodwgs () ;;copy entity to all dwgs
  (setq cad (vlax-get-acad-object))
  (setq ent (car (entsel)))
  (setq objs (vlax-make-safearray vlax-vbObject (cons 0 0)))
  (vlax-safearray-put-element objs 0 (vlax-ename->vla-object ent))
  (vlax-for item (vla-get-Documents cad)
    (if (/= (vla-get-name item)(getvar "dwgname"))
      (vla-copyobjects (vla-get-activedocument cad) objs (vla-get-modelspace item))
    )
  )
)

[/php]

qazxswedccc

能不能简单讲解讲解？？谢谢