快速制作并加载线型

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

本帖最后由 dcl1214 于 2024-6-15 21:52 编辑

(DEFUN $xian-xing-zi-ding-yi$ (lin-path LIN-NAMES
/ $jia-zai-xian-xing$
$make-lin$ $write-lin$
)
;($xian-xing-zi-ding-yi$ nil(list "abc" "123" "秦始皇"))
(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$ 遇到空值")
)
(tblobjname "LTYPE" xxm)
)
(defun $make-lin$ (str / cadrlst carlst L LIN-STR lst relst strs h)
(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.0)
(setq lst (vl-string->list str))
(setq L (LENGTH LST))
(if (AND str)
(progn
(SETQ L (* L h))
(SETQ LIN-STR (STRCAT "*" STR))
(SETQ LIN-STR (STRCAT LIN-STR "\n"))
(SETQ LIN-STR (STRCAT LIN-STR "A,"))
(SETQ
LIN-STR (STRCAT LIN-STR (VL-PRINC-TO-STRING (* L h)))
)
(SETQ LIN-STR (STRCAT LIN-STR ",-0.5,["))
(SETQ LIN-STR (STRCAT LIN-STR (VL-PRIN1-TO-STRING STR)))
(SETQ
LIN-STR
(STRCAT LIN-STR
",STANDARD,S="
(VL-PRIN1-TO-STRING h)
",R=0.0,X=0.0,Y=-"
(VL-PRIN1-TO-STRING (* h 0.45))
"],"
)
)
(SETQ
LIN-STR
(STRCAT
LIN-STR
(strcat "-" (VL-PRINC-TO-STRING (- L (* (LENGTH LST)h 0.25))))
)
)
)
)
LIN-STR
)
(defun $write-lin$ (lin-path str / f)
(if (and lin-path (SETQ lin-path (findfile lin-path)))
()
(PROGN
(SETQ F
(open (SETQ lin-path (strcat (getvar 'dwgprefix) "lin.lin"))
"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
)
)
;(if (FINDFILE "LIN.lin")(vl-file-delete(FINDFILE "LIN.lin")))
(if lin-path
()
(setq lin-path (findfile "LIN.lin"))
)
(setq LIN-NAMES (vl-remove nil 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))
LIN-NAME
)
)
)
)
)
LIN-NAMES
)
)

(DEFUN $xian-xing-zi-ding-yi$        (lin-path          LIN-NAMES 
                                 /                  $jia-zai-xian-xing$ 
                                 $make-lin$          $write-lin$ 
                                ) 
    ;($xian-xing-zi-ding-yi$ nil(list "abc" "123" "秦始皇")) 
    (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$  遇到空值") 
      ) 
      (tblobjname "LTYPE" xxm) 
    ) 
    (defun $make-lin$ (str / cadrlst carlst L LIN-STR lst relst strs h) 
      (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.0) 
      (setq lst (vl-string->list str)) 
      (setq L (LENGTH LST)) 
      (if (AND str) 
        (progn 
          (SETQ L (* L h)) 
          (SETQ LIN-STR (STRCAT "*" STR)) 
          (SETQ LIN-STR (STRCAT LIN-STR "\n")) 
          (SETQ LIN-STR (STRCAT LIN-STR "A,")) 
          (SETQ 
            LIN-STR (STRCAT LIN-STR (VL-PRINC-TO-STRING (* L h))) 
          ) 
          (SETQ LIN-STR (STRCAT LIN-STR ",-0.5,[")) 
          (SETQ LIN-STR (STRCAT LIN-STR (VL-PRIN1-TO-STRING STR))) 
          (SETQ 
            LIN-STR 
             (STRCAT LIN-STR 
                     ",STANDARD,S=" 
                     (VL-PRIN1-TO-STRING h) 
                     ",R=0.0,X=0.0,Y=-" 
                     (VL-PRIN1-TO-STRING (* h 0.45)) 
                     "]," 
             ) 
          ) 
          (SETQ 
            LIN-STR 
             (STRCAT 
               LIN-STR 
               (strcat "-" (VL-PRINC-TO-STRING (- L (* (LENGTH LST)h 0.25)))) 
             ) 
          ) 
        ) 
      ) 
      LIN-STR 
    )    
    (defun $write-lin$ (lin-path str / f) 
      (if (and lin-path (SETQ lin-path (findfile lin-path))) 
        () 
        (PROGN 
          (SETQ        F 
                 (open (SETQ lin-path (strcat (getvar 'dwgprefix) "lin.lin")) 
                       "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 
      ) 
    ) 
   ;(if (FINDFILE "LIN.lin")(vl-file-delete(FINDFILE "LIN.lin"))) 
    (if        lin-path 
      () 
      (setq lin-path (findfile "LIN.lin")) 
    ) 
    (setq LIN-NAMES (vl-remove nil 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)) 
                LIN-NAME 
              ) 
            ) 
          ) 
        ) 
      ) 
      LIN-NAMES 
    ) 
  )

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

感谢大佬的无私奉献

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

这是一个完整的lisp吗

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

感谢大佬的无私奉献

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

收下了，谢谢

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

厉害厉害，学到了。

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

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