[LISP程序]：一个制作消防光盘的工具

xiguao

消防局要求建筑设计后制作消防光盘，每张图出一个dwg的r14文件，而我们大多人用acad2000，在模型空间放多张图，基于此，想到做这么一个程序，按图框做wblock到新建文件夹内，并将各文件存为r14版。下面为程序，请大家多多指教。

;;;针对于消防报审需单张图
;|使用方法：暂时限于最终出图，图框使用签字栏在右面方式，图签中应有“（注册工程盖章处）”字样
选用世界坐标系
图框外框线应为单线，不能有重线，图框大小暂时按1:100出图
图名设置为平面图或系统图、立面图、原理图
输出图形请到原图目录下查找
图形需在模型空间完成
使用ACAD命令：xdb

|;


;;;保存图层现状
(defun nowlayerstat ()
  (setq i 0)
  (repeat (vla-get-count *layers*)
    (setq
      layerstat        (append        layerstat
                        (list (vla-get-lock (vla-item *layers* i)))
                )
    )
    (vla-put-lock (vla-item *layers* i) :vlax-false)
    (setq i (1+ i))
  )
)
;;;还原图层状态
(defun oldlayerstat ()
  (setq i 0)
  (repeat (vla-get-count *layers*)
    (vla-put-lock (vla-item *layers* i) (nth i layerstat))
    (setq i (1+ i))
  )
)

;;;图框不是块时处理选择
;;;找图框选择
(defun noblockdwg ()
  (princ "请选择所有出图单位：")
  (setq        dwgselect (ssget '((1 . "(注册工程师盖章处)")))
        dwgnumber (sslength dwgselect)
  )
  (newdwgpath)
  (setq i 0)
  (repeat dwgnumber
    (setq flagtext (ssname dwgselect i))
    (setq textpoint (cdr (assoc 10 (entget flagtext))))
    (setq secondpoint (polar textpoint (* PI (/ 225 180.0)) 2000))
    (setq bolines (ssget "_C" textpoint secondpoint '((0 . "line"))))
    (setq boline (ssname bolines 0))
    (redraw boline 3)
    (setq firlinepo (cdr (assoc 10 (entget boline))))
    (setq seclinepos
           (ssget "_c"
                  (polar firlinepo 3.5 30)
                  (polar firlinepo 0.2 30)
           )
    )
    (ssdel boline seclinepos)
    (setq seclinepo (ssname seclinepos 0))
    (if        (< (cadr (setq pointtop (cdr (assoc 10 (entget seclinepo)))))
           (cadr firlinepo)
        )
      (setq pointtop (cdr (assoc 11 (entget seclinepo))))
    )
    (setq pointlod (cdr (assoc 11 (entget boline))))
    (setq startpo (cdr (assoc 10 (entget boline)))
          endpo          (cdr (assoc 11 (entget boline)))
    )
    (if        (< (car startpo) (car endpo))
      (setq selpo endpo)
      (setq selpo startpo)
    )
    (setq newdwgnamesel
           (ssget "_c"
                  selpo
                  (polar selpo (* pi (/ 120 180.0)) 15000)
                  '((0 . "text"))
           )
    )
    (setq j 0)
    (while (<= j (sslength newdwgnamesel))
      (setq newdwgname
             (cdr (assoc 1 (entget (ssname newdwgnamesel j))))
      )
      (if (wcmatch newdwgname "*平面*,*系统*,*原理*,*立面*")
        (setq j (sslength newdwgnamesel))
      )
      (setq j (1+ j))
    )
    (setq newdwgpathname (strcat newpath "\\" newdwgname ".dwg"))
    (setq selectenti (ssget "_c" pointlod pointtop))
    (setq VLXselct (vla-get-ActiveSelectionSet *activedocument*))
    (princ "\r请稍候...")
    (vla-wblock *activedocument* newdwgpathname VLXselct)
    (setq i (1+ i))
  )
)

;;;图块输出
(defun newdwgpath ()
  (setq        dwgname        (getvar "dwgname")
        dwgpath        (getvar "dwgprefix")
  )
  (setq pathadd (vl-string-trim ".dwg" dwgname))
  (setq newpath (strcat dwgpath "fire-" pathadd))
  (setq folders (vlax-Create-Object "Scripting.FileSystemObject"))
  (if (= :vlax-true
         (vlax-invoke-method folders 'FolderExists newpath)
      )
    (vlax-invoke-method
      folders
      'DeleteFolder
      newpath
      :vlax-true
    )
  )
  (vlax-invoke-method folders 'CreateFolder newpath)
)

;;;ACAD2002转为R14
(defun changver        ()
  (setq        acadpref (vla-get-opensave
                   (vla-get-preferences
                     (vla-get-application *activedocument*)
                   )
                 )
  )
  (vla-put-saveastype acadpref acR14_dwg)
  (setq filesdwgs (vl-directory-files newpath "*.dwg" 1))
  (setq i 0)
  (repeat (length filesdwgs)
    (setq filesdwg (nth i filesdwgs))
    (setq newopendwg
           (vla-open (vla-get-Documents
                       (vla-get-Application *activedocument*)
                     )
                     (strcat newpath "\\" filesdwg)
           )
    )
    (setq i (1+ i))
  )
  (setq        doccount (vla-get-count
                   (vla-get-Documents
                     (vla-get-Application *activedocument*)
                   )
                 )
  )
  (repeat (1- doccount)
    (setq closedwg (vla-item (vla-get-Documents
                               (vla-get-Application *activedocument*)
                             )
                             1
                   )
    )
    (vla-regen closedwg acActiveViewport)
    (vla-save closedwg)
    (vla-close closedwg)
  )
  (vla-put-saveastype acadpref acr15_dwg)
)

;;;主函数
(princ "\n消防报审出图命令：xdb")
(defun c:xdb ()
  (setvar "sdi" 0)
  (vl-load-com)
  (setq *acadobj*               (vlax-get-acad-object)
      *activedocument* (vla-get-activedocument *acadobj*)
      *mspace*               (vla-get-modelspace *activedocument*)
      *layers*               (vla-get-layers *activedocument*)
      layerstat               '()
   )
  (nowlayerstat)
  (noblockdwg)
  (oldlayerstat)
  (changver)
  ;;;(setq vlxselct nil)
  (setq        *acadobj* nil
        *activedocument* nil
        *mspace* nil
        *layers* nil
        layerstat nil
        i nil
        j nil
        dwgselect nil
        dwgnumber nil
        flagtext nil
        textpoint nil
        secondpoint nil
        seclinepo nil
        bolines        nil
        boline nil
        firlinepo nil
        pointtop nil
        pointlod nil
        selpo nil
        startpo        nil
        endpo nil
        newdwgnamesel nil
        newdwgname nil
        newdwgpathname nil
        activeselects nil
        selectenti nil
        VLXselct nil
        dwgname        nil
        dwgpath        nil
        pathadd        nil
        newpath        nil
        folders        nil
  filesdwg nil newopendwg nil closedwg nil doccount nil)
  (princ)
)
(defun *error* (msg)
   (princ)
)

xiguao

哦，还有本程序参考的dwg文件

高手为什么不来评点一下，看看有没有更好的方法。
1、判断图框范围
2、设定图纸名称
3、文件另存版本
4、如何让非activedocument实现zoomextents功能？
5、就象程序中用到的"Scripting.FileSystemObject"，在VB中只能定义为object，但看不见任何属性等，creatobject方法还能加多少对象呀？
6、先解决上述问题吧

aeo

下一个批量转换的软件
到"小工具"去找

另一贴我删了!