增强的线型加载代码

Lisphk · 发表于 2021-1-20 15:57:13

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

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

×

(defun lt_load (ltname / StrBrk DCTAG F FILES FLAG FN L LLST LST NL PATH
TFILE TMP)
;; String Breaker by Lee McDonnell
(defun StrBrk (str chrc / pos lst)
(while (setq pos (vl-string-position chrc str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 2))
)
)
(reverse (cons str lst))
)
(foreach Path (vl-remove "" (StrBrk (getenv "ACAD") 59))
(and (setq files (vl-directory-files Path "*.lin" 1))
(setq lst
(append lst
(mapcar (function (lambda (x) (strcat Path "\\" x)))
files
)
)
)
)
)
(foreach file lst
(setq tmp (open file "r"))
(while (setq nl (read-line tmp))
(and (eq "*" (substr nl 1 1))
(eq (strcase ltname)
(setq l (strcase (car (StrBrk (substr nl 2) 44))))
)
(setq
llst (cons (cons l (strcat (vl-filename-base file) ".lin"))
llst
)
)
)
)
(close tmp)
)
(if lLst
(if (< 1 (length lLst))
(progn
(setq
fn (open (setq tfile (vl-filename-mktemp "" "" ".dcl")) "w")
)
(foreach str
'("lt_dcl : dialog { label = \"Select Load File\"; spacer;"
": popup_list { alignment = centered; key = \"flin\"; } spacer; ok_cancel; } "
)
(write-line str fn)
)
(close fn)
(if (and (<= 0 (setq dcTag (load_dialog tFile)))
(new_dialog "lt_dcl" dcTag)
)
(progn
(start_list "flin")
(mapcar 'add_list (mapcar 'cdr lLst))
(end_list)
(setq f (car lLst))
(action_tile "flin" "(setq f (nth (atoi $value) lLst))")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq flag (start_dialog))
(unload_dialog dcTag)
)
)
(vl-file-delete tfile)
)
(setq flag 1
f (car lLst)
)
)
)
(if (eq flag 1)
(vla-load
(vla-get-linetypes
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
(car f)
(cdr f)
)
)
(and (tblsearch "LTYPE" ltname))
)

(defun lt_load (ltname / StrBrk        DCTAG F        FILES FLAG FN L        LLST LST NL PATH 
                TFILE TMP) 
 
  ;; String Breaker by Lee McDonnell 
  (defun StrBrk        (str chrc / pos lst) 
    (while (setq pos (vl-string-position chrc str)) 
      (setq lst        (cons (substr str 1 pos) lst) 
            str        (substr str (+ pos 2)) 
      ) 
    ) 
    (reverse (cons str lst)) 
  ) 
 
  (foreach Path        (vl-remove "" (StrBrk (getenv "ACAD") 59)) 
    (and (setq files (vl-directory-files Path "*.lin" 1)) 
         (setq lst 
                (append        lst 
                        (mapcar        (function (lambda (x) (strcat Path "\\" x))) 
                                files 
                        ) 
                ) 
         ) 
    ) 
  ) 
 
  (foreach file        lst 
    (setq tmp (open file "r")) 
    (while (setq nl (read-line tmp)) 
      (and (eq "*" (substr nl 1 1)) 
           (eq (strcase ltname) 
               (setq l (strcase (car (StrBrk (substr nl 2) 44)))) 
           ) 
           (setq 
             llst (cons        (cons l (strcat (vl-filename-base file) ".lin")) 
                        llst 
                  ) 
           ) 
      ) 
    ) 
    (close tmp) 
  ) 
 
  (if lLst 
    (if        (< 1 (length lLst)) 
      (progn 
        (setq 
          fn (open (setq tfile (vl-filename-mktemp "" "" ".dcl")) "w") 
        ) 
        (foreach str 
                 '("lt_dcl : dialog { label = \"Select Load File\"; spacer;" 
                   ": popup_list { alignment = centered; key = \"flin\"; } spacer; ok_cancel; } " 
                  ) 
          (write-line str fn) 
        ) 
        (close fn) 
 
        (if (and (<= 0 (setq dcTag (load_dialog tFile))) 
                 (new_dialog "lt_dcl" dcTag) 
            ) 
          (progn 
 
            (start_list "flin") 
            (mapcar 'add_list (mapcar 'cdr lLst)) 
            (end_list) 
            (setq f (car lLst)) 
 
            (action_tile "flin" "(setq f (nth (atoi $value) lLst))") 
            (action_tile "accept" "(done_dialog 1)") 
            (action_tile "cancel" "(done_dialog 0)") 
 
            (setq flag (start_dialog)) 
            (unload_dialog dcTag) 
          ) 
        ) 
 
        (vl-file-delete tfile) 
      ) 
 
      (setq flag 1 
            f         (car lLst) 
      ) 
    ) 
  ) 
 
  (if (eq flag 1) 
    (vla-load 
      (vla-get-linetypes 
        (vla-get-ActiveDocument 
          (vlax-get-acad-object) 
        ) 
      ) 
      (car f) 
      (cdr f) 
    ) 
  ) 
 
  (and (tblsearch "LTYPE" ltname)) 
)

zero423 · 发表于 2021-1-21 10:36:15

跟大神学习学习!

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

[每日一码] 增强的线型加载代码

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