LISP: export linetype from drawing to .lin file??

[goldy2000]

;;;   ----------- 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)

Here is a lisp that found on internet, but not works (for me), can anyone try to see what happened here?? THX...

This lisp could be very usable for everyone..

Here is page where I picked it up..

http://www.theswamp.org/index.php?topic=506.msg6241

[VVA]

Try to use the a bit changed code. See post #8.

Changes:

Here a new variant (red changes are noted).

1. I have made local some variables since the program sometimes behaved not predictedly.

2. Also the algorithm of formation of a line with alignment codes since with some types of lines the old algorithm worked incorrectly (for example with type of a line "???" (non english name) from my post №3) is altered.

3. And the main thing - is entered change variable DIMZIN to suppress closing zero values in decimal numbers. More beautiful result First turns out. And secondly, I so have understood, in a file with types of lines there is a restriction on length of a line because some types of lines with long lines of codes of alignment at me did not wish to be loaded. But after closing zero have been cleaned, they (i.e. types of lines) were loaded without problems.

4. Well some cosmetic changes are still made.

[TimSpangler]

You could also post this to theswamp, I am sure that Keith would be more than happy to help you.