快速制作并加载线型

dcl1214 · 发表于 2024-6-15 21:27:24

本帖最后由 dcl1214 于 2024-10-2 16:36 编辑

(DEFUN $xian-xing-zi-ding-yi2$ (LST /
$jia-zai-xian-xing$
$make-lin$ $write-lin$
)
;文字线型自定义
;($xian-xing-zi-ding-yi2$(list (cons "字串"(list "-五星出东方-" "周伯通" "-7-")) (cons "间隔" nil)))
(defun $jia-zai-xian-xing$ (lin-path xxm / LinPath)
;这里的线型是加载单线型
(if xxm
(if (tblobjname "LTYPE" xxm)
()
(progn
(or (and lin-path (setq linpath (findfile lin-path)))
(setq linpath (findfile "zx.lin"))
)
(if
(not
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-load
(list
(vla-get-Linetypes
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
xxm
(vl-catch-all-apply 'findfile (LIST LinPath))
)
)
)
)
(tblobjname "LTYPE" xxm)
)
(IF (NOT (tblobjname "LTYPE" xxm))
(PROGN
(if (= (GETVAR 'PRODUCT) "ZWCAD")
(setq linpath (FINDFILE "zwcadiso.lin"))
(setq linpath (FINDFILE "acadiso.lin"))
)
(if
(not
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-load
(list
(vla-get-Linetypes
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
xxm
(findfile LinPath)
)
)
)
)
(tblobjname "LTYPE" xxm)
)
)
)
)
)
(print "$jia-zai-xian-xing$ 遇到空值")
)
(IF xxm
(tblobjname "LTYPE" xxm)
)
)
(defun $make-lin$
(str lst / box cadrlst carlst
jg L LIN-STR relst str-box-l
strs
)
(vl-catch-all-apply
'vla-put-Height
(list
(vla-item
(vla-get-TextStyles
(vla-get-ActiveDocument (vlax-get-acad-object))
)
"Standard"
)
0.0
)
)
(setq h 2.54)
(setq box (textbox (list (cons 1 str)
(cons 7 "Standard")
(cons 40 H)
(cons 41 1.0)
)
)
)
(setq str-box-L (ABS (APPLY '- (MAPCAR 'CAR BOX))))
(if (AND str)
(progn
(SETQ LIN-STR (STRCAT "*" STR))
(SETQ LIN-STR (STRCAT LIN-STR "\n"))
(SETQ LIN-STR (STRCAT LIN-STR "A,"))
(or (and (SETQ JG (CDR (ASSOC "间隔" LST)))
(member (type jg) (list 'int 'real))
(> jg 0)
(setq jg (vl-princ-to-string jg))
(SETQ
LIN-STR (STRCAT LIN-STR jg)
)
)
(SETQ
LIN-STR (STRCAT LIN-STR
(VL-PRINC-TO-STRING (* str-box-L 1.25))
)
)
)
(SETQ LIN-STR (STRCAT LIN-STR ",-0.1,["))
(SETQ LIN-STR (STRCAT LIN-STR (VL-PRIN1-TO-STRING STR)))
(SETQ
LIN-STR
(STRCAT LIN-STR
",Standard,S=2.54,R=0.0,X=0.0,Y=-"
(VL-PRIN1-TO-STRING (* h 0.5))
"],"
)
)
(SETQ
LIN-STR
(STRCAT
LIN-STR
(strcat "-"
(VL-PRINC-TO-STRING (+ str-box-L (* h 0.10)))
)
)
)
)
)
LIN-STR
)
(defun $write-lin$ (lin-path str / f lin-path)
(setq lin-path (strcat (getenv "temp") "\\zx.lin"))
(if (and lin-path (findfile lin-path))
(vl-file-delete lin-path)
)
(PROGN
(SETQ F (open lin-path "W"))
(IF F
()
(SETQ lin-path NIL)
)
(AND F (CLOSE F))
(SETQ F NIL)
)
(and lin-path (setq f (open lin-path "a")))
(and str f (write-line str f))
(and f (close f))
(IF F
lin-path
)
)
(setq LIN-NAMES (cdr (assoc "字串" lst)))
(if (= (type LIN-NAMES) 'str)
(setq LIN-NAMES (list LIN-NAMES))
)
(MAPCAR
(FUNCTION
(LAMBDA (LIN-NAME)
(IF ($jia-zai-xian-xing$ lin-path LIN-NAME)
()
(PROGN
($jia-zai-xian-xing$
($write-lin$ lin-path ($make-lin$ LIN-NAME lst))
LIN-NAME
)
)
)
)
)
LIN-NAMES
)
)
(defun str->chrlist (str / lst carlst cadrlst relst)
;字符串转表，不是分割成表,不是分隔成表
;(str->chrlist "数字123字母abc符号℃√⒙⑼<>《》()【】﹝﹞≮≯")(str->chrlist "")
(AND str (setq lst (vl-string->list str)))
(while lst
(setq carlst (car lst))
(setq cadrlst (cadr lst))
(if (< carlst 129)
(progn (setq relst (cons (list carlst) relst))
(setq lst (cdr lst))
)
(progn (setq relst (cons (list carlst cadrlst) relst))
(setq lst (cddr lst))
)
)
)
(IF relst
(mapcar 'vl-list->string (reverse relst))
)
)
(vla-purgeall
(vla-get-activedocument (vlax-get-acad-object))
)

(DEFUN $xian-xing-zi-ding-yi2$ (LST                 / 
                                $jia-zai-xian-xing$ 
                                $make-lin$         $write-lin$ 
                               ) 
                                        ;文字线型自定义 
                                        ;($xian-xing-zi-ding-yi2$(list (cons "字串"(list "-五星出东方-" "周伯通" "-7-")) (cons "间隔" nil))) 
  (defun $jia-zai-xian-xing$ (lin-path xxm / LinPath) 
                                        ;这里的线型是加载单线型   
    (if        xxm 
      (if (tblobjname "LTYPE" xxm) 
        () 
        (progn 
          (or (and lin-path (setq linpath (findfile lin-path))) 
              (setq linpath (findfile "zx.lin")) 
          ) 
          (if 
            (not 
              (vl-catch-all-error-p 
                (vl-catch-all-apply 
                  'vla-load 
                  (list 
                    (vla-get-Linetypes 
                      (vla-get-ActiveDocument 
                        (vlax-get-acad-object) 
                      ) 
                    ) 
                    xxm 
                    (vl-catch-all-apply 'findfile (LIST LinPath)) 
                  ) 
                ) 
              ) 
            ) 
             (tblobjname "LTYPE" xxm) 
          ) 
          (IF (NOT (tblobjname "LTYPE" xxm)) 
            (PROGN 
              (if (= (GETVAR 'PRODUCT) "ZWCAD") 
                (setq linpath (FINDFILE "zwcadiso.lin")) 
                (setq linpath (FINDFILE "acadiso.lin")) 
              ) 
              (if 
                (not 
                  (vl-catch-all-error-p 
                    (vl-catch-all-apply 
                      'vla-load 
                      (list 
                        (vla-get-Linetypes 
                          (vla-get-ActiveDocument 
                            (vlax-get-acad-object) 
                          ) 
                        ) 
                        xxm 
                        (findfile LinPath) 
                      ) 
                    ) 
                  ) 
                ) 
                 (tblobjname "LTYPE" xxm) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (print "$jia-zai-xian-xing$  遇到空值") 
    ) 
    (IF        xxm 
      (tblobjname "LTYPE" xxm) 
    ) 
  ) 
  (defun $make-lin$ 
                    (str             lst    /             box     cadrlst carlst 
                     jg             L             LIN-STR relst   str-box-l 
                     strs 
                    ) 
    (vl-catch-all-apply 
      'vla-put-Height 
      (list 
        (vla-item 
          (vla-get-TextStyles 
            (vla-get-ActiveDocument (vlax-get-acad-object)) 
          ) 
          "Standard" 
        ) 
        0.0 
      ) 
    ) 
    (setq h 2.54) 
    (setq box (textbox (list (cons 1 str) 
                             (cons 7 "Standard") 
                             (cons 40 H) 
                             (cons 41 1.0) 
                       ) 
              ) 
    ) 
    (setq str-box-L (ABS (APPLY '- (MAPCAR 'CAR BOX)))) 
    (if        (AND str) 
      (progn 
        (SETQ LIN-STR (STRCAT "*" STR)) 
        (SETQ LIN-STR (STRCAT LIN-STR "\n")) 
        (SETQ LIN-STR (STRCAT LIN-STR "A,")) 
        (or (and (SETQ JG (CDR (ASSOC "间隔" LST))) 
                 (member (type jg) (list 'int 'real)) 
                 (> jg 0) 
                 (setq jg (vl-princ-to-string jg)) 
                 (SETQ 
                   LIN-STR (STRCAT LIN-STR jg) 
                 ) 
            ) 
            (SETQ 
              LIN-STR (STRCAT LIN-STR 
                              (VL-PRINC-TO-STRING (* str-box-L 1.25)) 
                      ) 
            ) 
        ) 
        (SETQ LIN-STR (STRCAT LIN-STR ",-0.1,[")) 
        (SETQ LIN-STR (STRCAT LIN-STR (VL-PRIN1-TO-STRING STR))) 
        (SETQ 
          LIN-STR 
           (STRCAT LIN-STR 
                   ",Standard,S=2.54,R=0.0,X=0.0,Y=-" 
                   (VL-PRIN1-TO-STRING (* h 0.5)) 
                   "]," 
           ) 
        ) 
        (SETQ 
          LIN-STR 
           (STRCAT 
             LIN-STR 
             (strcat "-" 
                     (VL-PRINC-TO-STRING (+ str-box-L (* h 0.10))) 
 
             ) 
           ) 
        ) 
      ) 
    ) 
    LIN-STR 
  ) 
  (defun $write-lin$ (lin-path str / f lin-path) 
    (setq lin-path (strcat (getenv "temp") "\\zx.lin")) 
    (if        (and lin-path (findfile lin-path)) 
      (vl-file-delete lin-path) 
    ) 
    (PROGN 
      (SETQ F (open lin-path "W")) 
      (IF F 
        () 
        (SETQ lin-path NIL) 
      ) 
      (AND F (CLOSE F)) 
      (SETQ F NIL) 
    ) 
    (and lin-path (setq f (open lin-path "a"))) 
    (and str f (write-line str f)) 
    (and f (close f)) 
    (IF        F 
      lin-path 
    ) 
  ) 
  (setq LIN-NAMES (cdr (assoc "字串" lst))) 
  (if (= (type LIN-NAMES) 'str) 
    (setq LIN-NAMES (list LIN-NAMES)) 
  ) 
  (MAPCAR 
    (FUNCTION 
      (LAMBDA (LIN-NAME)        
        (IF ($jia-zai-xian-xing$ lin-path LIN-NAME) 
          () 
          (PROGN 
            ($jia-zai-xian-xing$ 
              ($write-lin$ lin-path ($make-lin$ LIN-NAME  lst)) 
              LIN-NAME 
            ) 
          ) 
        ) 
      ) 
    ) 
    LIN-NAMES 
  ) 
) 
(defun str->chrlist (str / lst carlst cadrlst relst) 
                                        ;字符串转表，不是分割成表,不是分隔成表 
                                        ;(str->chrlist "数字123字母abc符号℃√⒙⑼<>《》()【】﹝﹞≮≯")(str->chrlist "") 
  (AND str (setq lst (vl-string->list str))) 
  (while lst 
    (setq carlst (car lst)) 
    (setq cadrlst (cadr lst)) 
    (if        (< carlst 129) 
      (progn (setq relst (cons (list carlst) relst)) 
             (setq lst (cdr lst)) 
      ) 
      (progn (setq relst (cons (list carlst cadrlst) relst)) 
             (setq lst (cddr lst)) 
      ) 
    ) 
  ) 
  (IF relst 
    (mapcar 'vl-list->string (reverse relst)) 
  ) 
) 
(vla-purgeall 
  (vla-get-activedocument (vlax-get-acad-object)) 
)

yerenyi · 发表于 2024-6-15 22:25:11

感谢大佬的无私奉献

moranyuyan · 发表于 2024-6-15 22:43:02

这是一个完整的lisp吗

阿猪蛋 · 发表于 2024-6-17 08:32:38

感谢大佬的无私奉献

行天下 · 发表于 2024-6-18 08:12:14

收下了，谢谢

flowerson · 发表于 2024-6-18 17:19:11

厉害厉害，学到了。

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

[经验] 快速制作并加载线型