线型加载函数

Lisphk

1. ;;;====================[ Linetype-load.lsp ]=======================
   
2. ;;; Author: Copyright? 2008 Charles Alan Butler
   
3. ;;; Version:  1.0 July 9, 2008
   
4. ;;; Purpose:  function to load a list of linetypes
   
5. ;;; Sub_Routines: -None
   
6. ;;; Requirements: (Linetype-load lt-list (list "cab.lin"))
   
7. ;;; The first argument is a list of list containing the linetype name,
   
8. ;;; the preferred linetype file to search, this may be nil or missing if <reload-flag> is missing
   
9. ;;; and a t/nil flag to reload an existing linetype, this may be nil or missing
   
10. ;;;'((<lt-list> <lt-file-name> <reload-flag>)...)
    
11. ;;; <lt-list> (("hidden" "acad.lin" <lt-load-flag>)("dashed" "acad.lin") ...)
    
12. ;;; <lt-file-name> Optional, name of a LT file "lt-file01.lin", may be nil or missing if <reload-flag> is missing
    
13. ;;; <reload-flag> Optional, T / nil t=reload the linetype even if it exist in the DWG
    
14. ;;;   default for missing flag is nil and will not reload an existing linetype
    
15. ;;; Valid list are '((<lt-list>) (<lt-list> <lt-file-name>) (<lt-list> <lt-file-name> <reload-flag>))
    
16. ;;;
    
17. ;;; Second argument is a list of linetype files that will be searched after the preferred file if
    
18. ;;; the preferred file fails. This argument may be nil. The default ACAD LT file is always searched last.
    
19. ;;; <file-list> ("lt-file01.lin" "lt-file02.lin" ...)
    
20. ;;;
    
21. ;;; Returns: nil if successful else a list of failed linetype names
    
22. ;;;==========================================================
    
23. 
    
24. (defun Linetype-load (lt-list   ; '((<lt-list> <lt-file-name> <reload-flag>)...)
    
25.                       file-list ; '("lt-file01.lin" "lt-file02.lin" ...)
    
26.                       / lt-data ltypes fname ltname def-ltfile tmp-file-list
    
27.                       lt-loaded reload-flag idx err result)
    
28.   (vl-load-com)
    
29.   (setq ltypes (vla-get-linetypes
    
30.                  (vla-get-activedocument (vlax-get-acad-object))))
    
31.   ;;  set a default linetype file
    
32.   (if (zerop (getvar "measurement"))
    
33.     (setq def-ltfile "acad.lin")
    
34.     (setq def-ltfile "acadiso.lin")
    
35.   )
    
36.   ;; load the linetypes
    
37.   (foreach lt-data lt-list
    
38.     (setq ltname (car lt-data)
    
39.           fname  (cadr lt-data)
    
40.           reload-flag (caddr lt-data)
    
41.     )
    
42.     (setq lt-loaded (tblsearch "ltype" ltname)) ; does the LineType exist in the DWG
    
43.     (if file-list
    
44.       (if (not (vl-position (strcase def-ltfile) (mapcar 'strcase file-list)))
    
45.         (setq file-list (append file-list (list def-ltfile)))
    
46.       )
    
47.       (setq file-list (list def-ltfile))
    
48.     )
    
49.     (cond
    
50.       ((and (not reload-flag) lt-loaded)
    
51.        (prompt (strcat "\nLinetype " ltname " already loaded."))
    
52.        ;;  stop here and do not reload the linetype
    
53.       )
    
54.       ;; test a specific linetype file, never stops here though
    
55.       ((and fname (not (findfile fname))
    
56.        (princ (strcat "\nCan not fine file " fname))
    
57.        (setq fname nil))
    
58.       )
    
59.       (t ; Try & load linetype from file list, quit if loaded OK
    
60.        (if (and fname ; add it to the file list as first choice
    
61.                 (not (vl-position (strcase fname) (mapcar 'strcase file-list))))
    
62.          (setq tmp-file-list (cons fname file-list))
    
63.          (setq tmp-file-list file-list)
    
64.        )
    
65.        (setq idx 0)
    
66.        ;;  loop until LT is loaded or out of file choices
    
67.        (while (and
    
68.                 (< idx (length tmp-file-list))
    
69.                 (vl-catch-all-error-p
    
70.                   (setq err (vl-catch-all-apply
    
71.                               'vla-load (list ltypes ltname (nth idx tmp-file-list)))))
    
72.                 )
    
73.          (setq idx (1+ idx))
    
74.        )
    
75.        (cond  ; Report status of Load Attempt
    
76.          ((vl-catch-all-error-p err)
    
77.           (prompt (strcat "\n" (vl-catch-all-error-message err) " " ltname))
    
78.           (setq result (cons ltname result))
    
79.          )
    
80.          ((vla-item ltypes ltname)
    
81.           (prompt (strcat "\nLinetype " ltname " loaded from file " (nth idx tmp-file-list) "."))
    
82.          )
    
83.          (t
    
84.           (prompt (strcat "\nError Linetype " ltname " not loaded."))
    
85.           (setq result (cons ltname result))
    
86.          )
    
87.        )
    
88.       )
    
89.     )
    
90.   )
    
91.   result ; return a list of failed linetype names
    
92. )
    
93. 
    

;;;====================[ Linetype-load.lsp ]======================= <br /> ;;; Author: Copyright? 2008 Charles Alan Butler <br /> ;;; Version:  1.0 July 9, 2008<br /> ;;; Purpose:  function to load a list of linetypes<br /> ;;; Sub_Routines: -None <br /> ;;; Requirements: (Linetype-load lt-list (list "cab.lin"))<br /> ;;; The first argument is a list of list containing the linetype name, <br /> ;;; the preferred linetype file to search, this may be nil or missing if <reload-flag> is missing<br /> ;;; and a t/nil flag to reload an existing linetype, this may be nil or missing<br /> ;;;'((<lt-list> <lt-file-name> <reload-flag>)...)<br /> ;;; <lt-list> (("hidden" "acad.lin" <lt-load-flag>)("dashed" "acad.lin") ...)<br /> ;;; <lt-file-name> Optional, name of a LT file "lt-file01.lin", may be nil or missing if <reload-flag> is missing<br /> ;;; <reload-flag> Optional, T / nil t=reload the linetype even if it exist in the DWG<br /> ;;;   default for missing flag is nil and will not reload an existing linetype<br /> ;;; Valid list are '((<lt-list>) (<lt-list> <lt-file-name>) (<lt-list> <lt-file-name> <reload-flag>))<br /> ;;;<br /> ;;; Second argument is a list of linetype files that will be searched after the preferred file if<br /> ;;; the preferred file fails. This argument may be nil. The default ACAD LT file is always searched last.<br /> ;;; <file-list> ("lt-file01.lin" "lt-file02.lin" ...)<br /> ;;;<br /> ;;; Returns: nil if successful else a list of failed linetype names<br /> ;;;==========================================================<br /> <br /> (defun Linetype-load (lt-list   ; '((<lt-list> <lt-file-name> <reload-flag>)...)<br />                       file-list ; '("lt-file01.lin" "lt-file02.lin" ...)<br />                       / lt-data ltypes fname ltname def-ltfile tmp-file-list<br />                       lt-loaded reload-flag idx err result)<br />   (vl-load-com)<br />   (setq ltypes (vla-get-linetypes<br />                  (vla-get-activedocument (vlax-get-acad-object))))<br />   ;;  set a default linetype file<br />   (if (zerop (getvar "measurement"))<br />     (setq def-ltfile "acad.lin")<br />     (setq def-ltfile "acadiso.lin")<br />   )<br />   ;; load the linetypes<br />   (foreach lt-data lt-list<br />     (setq ltname (car lt-data)<br />           fname  (cadr lt-data)<br />           reload-flag (caddr lt-data)<br />     )<br />     (setq lt-loaded (tblsearch "ltype" ltname)) ; does the LineType exist in the DWG<br />     (if file-list<br />       (if (not (vl-position (strcase def-ltfile) (mapcar 'strcase file-list)))<br />         (setq file-list (append file-list (list def-ltfile)))<br />       )<br />       (setq file-list (list def-ltfile))<br />     )<br />     (cond<br />       ((and (not reload-flag) lt-loaded)<br />        (prompt (strcat "\nLinetype " ltname " already loaded."))<br />        ;;  stop here and do not reload the linetype<br />       )<br />       ;; test a specific linetype file, never stops here though<br />       ((and fname (not (findfile fname)) <br />        (princ (strcat "\nCan not fine file " fname))<br />        (setq fname nil))<br />       )<br />       (t ; Try & load linetype from file list, quit if loaded OK<br />        (if (and fname ; add it to the file list as first choice<br />                 (not (vl-position (strcase fname) (mapcar 'strcase file-list))))<br />          (setq tmp-file-list (cons fname file-list))<br />          (setq tmp-file-list file-list)<br />        )<br />        (setq idx 0)<br />        ;;  loop until LT is loaded or out of file choices<br />        (while (and<br />                 (< idx (length tmp-file-list))<br />                 (vl-catch-all-error-p<br />                   (setq err (vl-catch-all-apply<br />                               'vla-load (list ltypes ltname (nth idx tmp-file-list)))))<br />                 )<br />          (setq idx (1+ idx))<br />        )<br />        (cond  ; Report status of Load Attempt<br />          ((vl-catch-all-error-p err)<br />           (prompt (strcat "\n" (vl-catch-all-error-message err) " " ltname))<br />           (setq result (cons ltname result))<br />          )<br />          ((vla-item ltypes ltname)<br />           (prompt (strcat "\nLinetype " ltname " loaded from file " (nth idx tmp-file-list) "."))<br />          )<br />          (t<br />           (prompt (strcat "\nError Linetype " ltname " not loaded."))<br />           (setq result (cons ltname result))<br />          )<br />        )<br />       )<br />     )<br />   )<br />   result ; return a list of failed linetype names<br /> )<br /> <br />

测试代码：

1. (defun c:tt(/ lt-list fail-list)
   
2.   (setq lt-list '(("hidden" "acad.lin")
   
3.                   ("Very Fine Dot")
   
4.                   ("batting")
   
5.                   ("center" "acad.lin" t)
   
6.                   ("border" "acad.lin")
   
7.                   ("dot" "acad.lin")
   
8.                   ("tracks" "C:\\l-type\\Ln.lin")
   
9.                   ("phantom" "C:\\l-type\\Ln.lin")
   
10.                   ("xyz" "cab.lin")
    
11.                  )
    
12.   )
    
13.   (setq fail-list (Linetype-load lt-list (list "cab.lin")))
    
14.   (if  fail-list
    
15.     (print "Failed to load linetypes:")
    
16.   )
    
17.   (mapcar 'print fail-list)
    
18.   (princ)
    
19. )
    
20. 
    

(defun c:tt(/ lt-list fail-list)<br />   (setq lt-list '(("hidden" "acad.lin")<br />                   ("Very Fine Dot")<br />                   ("batting")<br />                   ("center" "acad.lin" t)<br />                   ("border" "acad.lin")<br />                   ("dot" "acad.lin")<br />                   ("tracks" "C:\\l-type\\Ln.lin")<br />                   ("phantom" "C:\\l-type\\Ln.lin")<br />                   ("xyz" "cab.lin")<br />                  )<br />   )<br />   (setq fail-list (Linetype-load lt-list (list "cab.lin")))<br />   (if  fail-list<br />     (print "Failed to load linetypes:")<br />   )<br />   (mapcar 'print fail-list)<br />   (princ)<br /> )<br /> <br />

sicky111

沙发，谢谢分享。