***** 快速好用 自定 線型文字編輯器 *****
本帖最后由 lee50310 于 2020-12-13 09:59 编辑<<<快速好用 自定 線型文字編輯器>>>
可快速自定出你自己想要的 線型文字並指定在那個圖層 也可編輯修改 線型文字
使用指令 :makelt
;;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: '((x1 y1 z1)_min (x2 y2 z2)_max)
;ver:
; 明经 Longxin, Gu_xl&邹锋
; by woyb 20151010
; 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
) 楼主的程序挺好的，唯一的缺点就是线型中的文字不在线的起点和终点之间对中
可参考下这个，在论坛里的
;;示例(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-24 08:50 编辑
yangchao2005090 发表于 2021-8-19 09:16
请问一下，这个线型编辑器生成的线型文件lin文件存放在哪个地方啊
如果你設定一個新線型 則新線型格式 會暫存在 程式的變數 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"
上传了，不管用请问怎么可以做出来废弃线型？
sunqv 发表于 2020-12-12 19:39
上传了，不管用请问怎么可以做出来废弃线型？
廢氣管段 文字線型 操作方式
和我上面发的线型不一样呀大神？我那个线型是5mm，1mm空格，实线上面有个x 太实用了，感谢楼主。
很不错
简单的文字线型用这个创建很方便
可以考虑下加入文字旋转角度、是否居中等设定
另外注意下高版本里线型定义里的新参数
新参数找到原帖了
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=181618&highlight=%D0%C2%B2%CE%CA%FD 本帖最后由 lee50310 于 2020-12-14 13:43 编辑
可以考虑下加入文字旋转角度、是否居中等设定
另外注意下高版本里线型定义里的新参数
感謝回復, 已後新版本可以增加此項
新参数找到原帖了
感謝告知
感谢分享，非常的有用 谢谢楼主分享。