社区 › AutoLISP/Visual LISP 编程技术 › 快速制作并加载线型

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-NAMElst))
              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

厉害厉害，学到了。

查看完整版本: 快速制作并加载线型