***** 快速好用自定線型文字編輯器 *****

lee50310 · 发表于 2020-12-12 13:35:00

>>
可快速自定出你自己想要的線型文字並指定在那個圖層也可編輯修改線型文字
使用指令 :makelt

簡體版

繁體版

yquq032pxxh.jpg

ix4nmr4iflf.jpg

zrzpkzualuy.jpg

gjank2r0ihg.jpg

yangchao2005090 · 发表于 2021-8-20 15:02:00

copy


;;http://bbs.mjtd.com/thread-183496-1-1.html
(defun c:tt (/ cmde lst p1 ss ss1)
        (setq cmde (getvar "CMDECHO"))
        (setvar "CMDECHO" 0)
        (prompt "\n框选需要合并的表格：")
        (while (setq ss (ssget))
                (setq lst (reverse (wyb-get-box ss)))
                (setq p1 (caar lst) lst (cdr lst))
                (if (/= lst nil)
                        (foreach x lst
                                (setq ss1 (ssget "w" (car x) (cadr x)))
                                (vl-cmdf "_.move" ss1 "" "non" (list (caar x) (cadadr x)) "non" p1)
                                (setq p1 (polar p1 (* 1.5 pi) (distance (car x) (list (caar x) (cadadr x)))))
                        )
                        (prompt "\n没有需要合并的表格。")
                )
                (prompt "\n框选需要合并的表格：")
        )
        (setvar "CMDECHO" cmde)
        (prompt "\n表格合并完成！")
        (princ)
)
;|= 4.2. 取得图元外矩形框
;@== (wyb-get-box ename)
;#== return: [plst]'((x1 y1 z1)_min (x2 y2 z2)_max)
;ver: 
;    [1.0] 乐筑天下 Longxin, Gu_xl&邹锋
;    [1.1] by woyb 20151010
;    [1.1.1] ADD: 释放obj by woyb 20180730
;====================|;
(defun wyb-get-box (@e / p1 p2 p3 p4 obj lst tmp)
    (setq obj (vlax-ename->vla-object @e))
    (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'p1 'p3))))
        (progn
            (setq p1 (vlax-safearray->list p1)
                p3 (vlax-safearray->list p3)
                p2 (list (car p1) (cadr p3) (caddr p1))
                p4 (list (car p3) (cadr p1) (caddr p1))
            )
            (if (= "SPLINE" (cdr (assoc 0 (entget @e))))
                (progn
                    (setq lst
                        (mapcar '(lambda  (a b) (vlax-curve-getClosestPointToProjection @e a b t))
                            (list p1 p2 p3 p4)
                            '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
                        )
                    )
                    (setq tmp 
                        (list
                            (apply 'mapcar (cons 'min lst))
                            (apply 'mapcar (cons 'max lst))
                        )
                    )
                )
                (setq tmp (list p1 p3))
            )
        )
        (setq tmp nil)
    )
    (vlax-release-object obj)
    tmp
)

KO你 · 发表于 2021-8-13 17:52:00

楼主的程序挺好的，唯一的缺点就是线型中的文字不在线的起点和终点之间对中
可参考下这个，在论坛里的
;;示例(HH:InputBox "显示重量,便于拷贝" "重量显示" "5.3")
(defun HH:InputBox (promptstr title default)
  ;;(setq str (VL-PRIN1-TO-STRING default))
  (wscriptPublic (strcat "dim ret \n ret=InputBox(\""             promptstr
                     "\", \""          title             "\", \""
                     default          "\")"
                     )
  )
)
;;[功能] 创建带文字的线型
(defun c:makelt (/ EXPRT FILE FN SS STR)
  ;; 错误处理
  (defun *error* (msg)
(vl-bt)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(cond (exprt (setvar 'expert exprt)))
(setvar "nomutt" 0)
(princ "\n 出错啦!")
(princ)
  )
  (setq exprt (getvar 'expert))
  ;;(setq str (getstring T "\n Enter string for linetype: "))
  (setvar "nomutt" 1)
  (cond       ((and (princ "\n 拾取或者输入线型文字")
            (setq ss (ssget "_+.:E:S" '((0 . "TEXT"))))
      )
      (setq str (cdr (assoc 1 (entget (ssname ss 0)))))
      )
      (T
      (while (equal (setq str (HH:InputBox "线型中有文字" "带文字线型" "电线")) ""))
      )
  )
  (setvar "nomutt" 0)
  (setq File (vl-filename-mktemp nil nil ".lin"))
  ;;(setq file (strcat (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname)) "_mylt.lin"))
  (setq fn (open file "w"))
  (setq exprt (getvar 'expert))
  (write-line (strcat "*" str ", ---" str "---") fn)
  (write-line (strcat "A,0.5,-0.05,[\""
                  str
                  "\",STANDARD,S=0.1,R=0.0,X=-0.0,Y=-.05],"
                  (rtos (* -0.1 (strlen str)) 2 3)
            )
            fn
  )
  (close fn)
  (setvar 'expert 5)
  (command ".-linetype" "load" "*" file "")
  (setvar 'expert exprt)
  (vl-file-delete file);这句好象没有什么用处
  (princ))

lee50310 · 发表于 2021-8-19 11:36:00

如果你設定一個新線型則新線型格式會暫存在程式的變數 ltdef 內
例: 查看變數內容可在cad 的 Connand: !ltdef 按Enter
回應: "\n*USER,--- - ---BE--- - ---BE--- - ---BE--- - ---\nA,4.375,-1.25,1.25,-1.25,4.375,-1.91467,[\"BE\",Standard,S=1.5,R=0.0,X=-1.26467,Y=-0.75],-1.91467"