[编程交流] LISP: export linetype from dra

;;;   ----------- LTExtract - Version 1.1 -----------;;;   Copyright (C) 2002-2008  by ResourceCAD International;;;   Author:   K.E. Blackie;;;   ;;;   ;;;   BCI COMPUTER SOLUTIONS PROVIDES THIS PROGRAM "AS IS" AND WITH;;;   ALL FAULTS. RESOURCECAD INTERNATIONAL SPECIFICALLY DISCLAIMS ANY;;;   IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR;;;   USE.  RESOURCECAD INTERNATIONAL DOES NOT WARRANT THAT THE OPERATION;;;   OF THE PROGRAM WILL BE UNINTERRUPTED OR ERROR FREE.;;;   ;;;   ;;;   ResouceCAD International;;;   http://www.resourcecad.com;;;   ;;;   DESCRIPTION;;;   LTExtract will extract all of the linetypes defined in a drawing to a seperate;;;   linetype definition file, including complex linetypes using text and shape;;;   modifiers.;;;;;;   August 17, 2002;;;   April 23, 2008;;;;;;   ------------------------------------------------------------(defun c:ltextract () (setq ltlist (tblnext "LTYPE" t)) (if ltlist   (setq ltlist (entget (tblobjname "LTYPE" (cdr (assoc 2 ltlist))))) ) (setq ltfile (getvar "dwgname")) (if (= (strcase (substr ltfile (- (strlen ltfile) 3) 4))    (strcase ".dwg")     )   (setq     ltfile (strcat (substr ltfile 1 (- (strlen ltfile) 4)) ".lin")   )   (setq ltfile (strcat ltfile ".lin")) ) (setq ltfile (getfiled "Save Linetype Definition As" ltfile "lin" 9)) (if ltfile   (progn     (setq fn (open ltfile "w"))     (while ltlist   (setq ltname (strcat "*" (strcase (cdr (assoc 2 ltlist))))         ltdesc (cdr (assoc 3 ltlist))   )   (setq ltdef "A"         wval nil   )   (setq ltlist (member (assoc 49 ltlist) ltlist))   (while (assoc 49 ltlist)     (setq wval (get74 ltlist))     (setq def (cdr (assoc 49 ltlist)))     (setq def (strcat "," (rtos def 2 ))     (if wval       (setq ltdef (strcat ltdef wval def))       (setq ltdef (strcat ltdef def))     )     (if (> (length ltlist) 1)       (setq ltlist (cdr (member (assoc 49 ltlist) ltlist)))       (setq ltlist (list nil))     )   )   (setq ltlist (tblnext "LTYPE"))   (if ltlist     (progn       (setq ltlist          (entget (tblobjname "LTYPE" (cdr (assoc 2 ltlist)))          )       )     )   )   (if (/= ltdef "A")     (progn       (write-line (strcat ltname "," ltdesc) fn)       (write-line ltdef fn)     )   )     )     (close fn)   ) ) (princ))(defun get74 (wlist / rval) (setq ass74 (cdr (assoc 74 wlist))) (cond   ((= ass74 0) (return nil nil nil nil))   ((= ass74 1)    (return (cdr (assoc 2 (entget (cdr (assoc 340 wlist)))))        nil        "a"        nil    )   )   ((= ass74 2)    (return (cdr (assoc 2 (entget (cdr (assoc 340 wlist)))))        (cdr (assoc 9 wlist))        "r"        nil    )   )   ((= ass74 3)    (return (cdr (assoc 2 (entget (cdr (assoc 340 wlist)))))        (cdr (assoc 9 wlist))        "a"        nil    )   )   ((= ass74 4)    (return (cdr (assoc 3 (entget (cdr (assoc 340 wlist)))))        nil        "r"        (cdr (assoc 75 wlist))    )   )   ((= ass74 5)    (return (cdr (assoc 3 (entget (cdr (assoc 340 wlist)))))        nil        "a"        (cdr (assoc 75 wlist))    )   )   (T (return nil nil nil nil)) ) rval)(defun return (shx text rot shp / ttext) (setq test (cdr (assoc 50 wlist))) (if (and test rot)   (setq rot (strcat rot "=" (angtos test))) ) (setq test (cdr (assoc 46 wlist))) (if (and test rot)   (setq rot (strcat rot ",S=" (rtos test 2 )) ) (setq test (cdr (assoc 44 wlist))) (if (and test rot)   (setq rot (strcat rot ",X=" (rtos test 2 )) ) (setq test (cdr (assoc 45 wlist))) (if (and test rot)   (setq rot (strcat rot ",Y=" (rtos test 2 )) ) (if text   (setq ttext (strcat ",["" text ""," shx "," rot "]")) ) (if (and (not text) shp)   (setq ttext (strcat ",[" (getname shp shx) "," shx "," rot "]")) ) (setq rval ttext))(defun getname (shape shapefile) (setq shapefile (findfile shapefile)) (if (setq sfn (open shapefile "r"))   (progn     (repeat 23   (read-char sfn)     )     (setq lownum (read-char sfn))     (read-char sfn)     (setq charcount (- shape lownum))     (setq hignum (read-char sfn))     (read-char sfn)     (setq shpcount (read-char sfn))     (read-char sfn)     (repeat (* shpcount 4)   (read-char sfn)     )     (setq zerocount 0)     (while (< zerocount (* charcount 2))   (setq this (read-char sfn))   (if (= this 0)     (setq zerocount (1+ zerocount))   )     )     (setq char1 (read-char sfn))     (setq name "")     (while (/= 0 char1)   (setq name (strcat name (chr char1)))   (setq char1 (read-char sfn))     )     (close sfn)     name   ) ))(princ)