马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
- ;;;====================[ Linetype-load.lsp ]=======================
- ;;; Author: Copyright? 2008 Charles Alan Butler
- ;;; Version: 1.0 July 9, 2008
- ;;; Purpose: function to load a list of linetypes
- ;;; Sub_Routines: -None
- ;;; Requirements: (Linetype-load lt-list (list "cab.lin"))
- ;;; The first argument is a list of list containing the linetype name,
- ;;; the preferred linetype file to search, this may be nil or missing if <reload-flag> is missing
- ;;; and a t/nil flag to reload an existing linetype, this may be nil or missing
- ;;;'((<lt-list> <lt-file-name> <reload-flag>)...)
- ;;; <lt-list> (("hidden" "acad.lin" <lt-load-flag>)("dashed" "acad.lin") ...)
- ;;; <lt-file-name> Optional, name of a LT file "lt-file01.lin", may be nil or missing if <reload-flag> is missing
- ;;; <reload-flag> Optional, T / nil t=reload the linetype even if it exist in the DWG
- ;;; default for missing flag is nil and will not reload an existing linetype
- ;;; Valid list are '((<lt-list>) (<lt-list> <lt-file-name>) (<lt-list> <lt-file-name> <reload-flag>))
- ;;;
- ;;; Second argument is a list of linetype files that will be searched after the preferred file if
- ;;; the preferred file fails. This argument may be nil. The default ACAD LT file is always searched last.
- ;;; <file-list> ("lt-file01.lin" "lt-file02.lin" ...)
- ;;;
- ;;; Returns: nil if successful else a list of failed linetype names
- ;;;==========================================================
- (defun Linetype-load (lt-list ; '((<lt-list> <lt-file-name> <reload-flag>)...)
- file-list ; '("lt-file01.lin" "lt-file02.lin" ...)
- / lt-data ltypes fname ltname def-ltfile tmp-file-list
- lt-loaded reload-flag idx err result)
- (vl-load-com)
- (setq ltypes (vla-get-linetypes
- (vla-get-activedocument (vlax-get-acad-object))))
- ;; set a default linetype file
- (if (zerop (getvar "measurement"))
- (setq def-ltfile "acad.lin")
- (setq def-ltfile "acadiso.lin")
- )
- ;; load the linetypes
- (foreach lt-data lt-list
- (setq ltname (car lt-data)
- fname (cadr lt-data)
- reload-flag (caddr lt-data)
- )
- (setq lt-loaded (tblsearch "ltype" ltname)) ; does the LineType exist in the DWG
- (if file-list
- (if (not (vl-position (strcase def-ltfile) (mapcar 'strcase file-list)))
- (setq file-list (append file-list (list def-ltfile)))
- )
- (setq file-list (list def-ltfile))
- )
- (cond
- ((and (not reload-flag) lt-loaded)
- (prompt (strcat "\nLinetype " ltname " already loaded."))
- ;; stop here and do not reload the linetype
- )
- ;; test a specific linetype file, never stops here though
- ((and fname (not (findfile fname))
- (princ (strcat "\nCan not fine file " fname))
- (setq fname nil))
- )
- (t ; Try & load linetype from file list, quit if loaded OK
- (if (and fname ; add it to the file list as first choice
- (not (vl-position (strcase fname) (mapcar 'strcase file-list))))
- (setq tmp-file-list (cons fname file-list))
- (setq tmp-file-list file-list)
- )
- (setq idx 0)
- ;; loop until LT is loaded or out of file choices
- (while (and
- (< idx (length tmp-file-list))
- (vl-catch-all-error-p
- (setq err (vl-catch-all-apply
- 'vla-load (list ltypes ltname (nth idx tmp-file-list)))))
- )
- (setq idx (1+ idx))
- )
- (cond ; Report status of Load Attempt
- ((vl-catch-all-error-p err)
- (prompt (strcat "\n" (vl-catch-all-error-message err) " " ltname))
- (setq result (cons ltname result))
- )
- ((vla-item ltypes ltname)
- (prompt (strcat "\nLinetype " ltname " loaded from file " (nth idx tmp-file-list) "."))
- )
- (t
- (prompt (strcat "\nError Linetype " ltname " not loaded."))
- (setq result (cons ltname result))
- )
- )
- )
- )
- )
- result ; return a list of failed linetype names
- )
测试代码:
- (defun c:tt(/ lt-list fail-list)
- (setq lt-list '(("hidden" "acad.lin")
- ("Very Fine Dot")
- ("batting")
- ("center" "acad.lin" t)
- ("border" "acad.lin")
- ("dot" "acad.lin")
- ("tracks" "C:\\l-type\\Ln.lin")
- ("phantom" "C:\\l-type\\Ln.lin")
- ("xyz" "cab.lin")
- )
- )
- (setq fail-list (Linetype-load lt-list (list "cab.lin")))
- (if fail-list
- (print "Failed to load linetypes:")
- )
- (mapcar 'print fail-list)
- (princ)
- )
|