[分享]：如何用lisp列出层的详细信息？

highflybird · 发表于 2007-5-17 20:26:47

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 Highflybird 于 2013-7-10 17:29 编辑

这是根据《The Visual Lisp Devepolers Bible-2003 Edition》的代码段改写的关于层的详细列表的lisp程序。以供大家参考。
最终的结果以网页形式列出。
[pcode=lisp,true]
(prompt "Please run with Command: \"Dumplayers\"\n")
(defun C:DumpLayers ( / *APP doc dwg layers name col ltp lwt pst onoff
                     frz lock plotTb dat path olist outfile output)
  (vl-load-com)
  (setq *APP (vlax-get-acad-object)
      doc (vla-get-activedocument *APP)
      dwg (vla-get-name doc)
      path (vla-get-path doc)
      layers (vla-get-layers doc)
      laylst (tbl_NL "LAYER")                         ; have been sorted
  )
  ;;(vlax-for each layers                               ; have been modified
  (foreach each laylst
(setq name  (vla-get-name each)
      ;;col (itoa (dsx-get-color each))             ; see Chapter 25!
      col (get-color each)                         ; have been modified
      ltp (vla-get-linetype each)
      lwt (itoa (vla-get-lineweight each))
      lwt (if (= lwt "-3") "Defualt" lwt)          ; have been modified
      pst (vla-get-plotstylename each)
      onoff (if (= :vlax-true (vla-get-layeron each))
               "ON"
               "OFF"
            )
      frz (if (= :vlax-true (vla-get-freeze each))
               "FROZEN"
               "THAWED"
            )
      lock  (if (= :vlax-true (vla-get-lock each))    ; have been modified
               "LOCKED"
               "UNLOCKED"
            )
      pltTb (if (= :vlax-true (vla-get-plottable each)); have been modified
               "PRINTABLE"
               "UNPRINTABLE"
            )
      dat (list name col ltp lwt onoff frz lock pst pltTb)
      olist (cons dat olist)

)
  ); vlax-for
  (setq olist (reverse olist))
  (setq olist
(cons
   (list  "Name" "Color" "Linetype" "Lineweight" "ON" "Freeze" "Lock" "PrintstyleName" "Printalbe")
   olist
)
  )
  (vlax-release-object layers)
  (vlax-release-object doc)
  (vlax-release-object *APP)
  (cond
( olist
   (setq outfile (strcat (vl-filename-base dwg) ".htm"))
   (setq outfile (strcat path "\\" outfile))
   (cond
      ( (setq output (open outfile "w"))
      (write-line "<html>" output)
      (write-line "<head><title>" output)
      (write-line (strcat "Layer Dump: " dwg) output)
      (write-line "</title></head><body>" output)
      (write-line (strcat "<b>Drawing: " path "\\" dwg "</b><br>") output)
      (write-line "<table border=1>" output)
      (foreach layset olist
         (write-line "<tr>" output)
         (foreach prop layset
            (write-line (strcat "<td>" prop "</td>") output) )
            (write-line "</tr>" output)
         ); foreach layer set
      (write-line "</table></body></html>" output)
      (close output)
      (setq output nil)
      (princ "\nReport finished! Opening in browser...")
      (vl-cmdf "_.browser" outfile)
      )
      ( T (princ "\nUnable to open output file.") )
   )
)
( T (princ "\nUnable to get layer table information.") )
  )
  (princ)
)
;;;get layer color
(defun dsx-get-color (obj / try)             ;???
  (cond
( (and
      (vlax-property-available-p obj 'color)
      (not
      (vl-catch-all-error-p
         (setq try
            (vl-catch-all-apply 'vla-get-color (list obj ))
         )
      )
      )
   )
   try
)
  )
)
;;;my get layer color
(defun get-color (obj / CADver colobj method R G B color)
  (setq CADver (getvar "ACADVER"))
  (if (> (atoi (substr CADver 1 2)) 15)       ;if version higher than R15
(progn
   (setq colobj (vla-get-truecolor obj))    ;get layer truecolor
   (setq method (vla-get-colorMethod colobj));get colorMethod
   (if (= method 194)
      (setq R (itoa (vla-get-red colobj))
            G (itoa (vla-get-green colobj))
            B (itoa (vla-get-blue colobj))
            color (strcat  R "," G "," B)    ;get truecolor RGB
      )
      (itoa (vla-get-color obj))             ;get layer index color
   )
)
(itoa (vla-get-color obj))                ;get layer index color
  )
)
;;; get the name list of layer
(defun tblname (tblsym / name namlst)
  (setq namlst nil)
  (setq namlst (cons (cdr (assoc 2 (tblnext tblsym T))) namlst))
  (while (setq name (cdr (assoc 2 (tblnext tblsym))))
(setq namlst (cons name namlst))
  )
  (setq namlst (acad_strlsort namlst))
  (mapcar '(lambda (x) (vla-item layers x)) namlst)
)

;;;tabLe name List
(DEFUN tbL_nL (tn / td L)
  (whiLe (setq td (tbLnext tn (not td)))
(setq L (cons (cdr (assoc 2 td)) L))
  )
  (mapcar '(lambda (x) (vla-item layers x))(acad_strlsort L))
)[/pcode]

登录/注册后可看大图

支持中文名。

firstintimate · 发表于 2007-5-18 09:32:04

中文层名不支持

haibinpro · 发表于 2007-5-19 07:51:45

我这边支持啊啊。

GTJ116600 · 发表于 2013-7-10 16:57:31

好程序，高飞鸟版主真强大

纯VLISP版查看图层信息

819534890 · 发表于 2013-7-10 23:41:07

函数列表控制在哪？

819534890 · 发表于 2013-7-10 23:42:24

刚才发错了，怎样删除？

XMAN2013 · 发表于 2013-7-15 20:17:45

报个名来学习的。

frantatu · 发表于 2013-8-17 13:38:08

非常不错！

账号		自动登录	找回密码
密码			立即注册

[飞鸟集] [分享]：如何用lisp列出层的详细信息？

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

本帖被以下淘专辑推荐:

相关帖子