- 积分
- 949
- 明经币
- 个
- 注册时间
- 2022-7-17
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
本帖最后由 YuHB 于 2024-6-12 23:10 编辑
;;;综合题主(尘缘一生)代码和题主提供链接中狼大师 (langjs)的帖子，稍微修改了下。
;;;这个应该是可以直接用的。
;;;感谢各位大师提供源码，膜拜大师啊。
(defun c:tt (/ code data ent ent1 ent2 enttx enttx1 enttx2 gr loop lst pt r r0 r1 r2 r3 r4 sltex oldorh jtk d1 d2 d3 d4 s htbl pi2 3pi2 Font1)
(setq oldorh (getvar "ORTHOMODE"))
(setvar "ORTHOMODE" 1)
(setq htbl 100 ;;比例设置
pi2 (* 0.5 pi)
3pi2 (* 1.5 pi)
);;参数赋值
;(_undo1)
(command ".UNDO" "BE")
(setq Font1 "Temp");;字体设置，根据自己要求修改
(if (null (tblsearch "style" Font1))
(entmake (list '(0 . "style") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbTextStyleTableRecord")
(cons 2 Font1) '(70 . 0) (cons 41 0.7) '(3 . "tssdeng.shx") '(4 . "hzfsex.shx")))
);;字体设置,YuHB补充
(setq sltex (slquzf)) ;取字符功能
(setq pt (getpoint (strcat "\n 指定起点,或捕捉对齐点: <符号: " sltex " >")))
(if (ssget "c" pt pt) (setq pt (getpoint pt "\n 指定起点,或<捕捉对齐点>:")))
(setq lst (list pt))
(princ "\n 指定折点,或<结束选点>:")
(setq s (entlast) jtk (* htbl 0.3) d1 (* htbl 4.0) d2 (* htbl 5.0) d3 (* htbl 1.1) d4 (* htbl 3.0)) ;d1 直段长度 d2控制文字远近 d3 箭头直段长度 d4 箭头长度
(while (setq pt (getpoint pt))
(setq lst (cons pt lst))
(if (= (length lst) 2)
(mkpolyline2 (cadr lst) (polar (cadr lst) (angle (cadr lst) pt) d1) jtk) ;直段
)
(if (>= (length lst) 2)
(progn
(if ent (entmod (reent ent (list (polar (cadr lst) (angle (cadr lst) pt) d1)))));直段
(setq ent (entget (mkpolyline3 pt jtk jtk pt jtk jtk (polar pt (angle pt (cadr lst)) d1))));垂直两直段
)
)
)
(if (= (getvar "dimblk") "")
(progn ;机械带箭头
(setq ent1 (entget (mkpolyline3 (car lst) jtk jtk (car lst) (* htbl 1.2) 0.0 (car lst))))
(setq ent2 (entget (mkpolyline3 (last lst) jtk jtk (last lst) (* htbl 1.2) 0.0 (last lst))))
)
(progn ;建筑取消箭头
(setq ent1 (entget (mkpolyline3 (car lst) jtk jtk (car lst) jtk jtk (car lst))))
(setq ent2 (entget (mkpolyline3 (last lst) jtk jtk (last lst) jtk jtk (last lst))))
)
)
(setq loop t)
(setvar "ORTHOMODE" oldorh)
(princ "\n 移动鼠标,指定箭头方向:")
(while loop
(setq gr (grread t 15 0) code (car gr) data (cadr gr))
(cond
((= code 5)
(setq r0 (get3ptang (cadr lst) (car lst) data))
(if (<= r0 pi)
(setq r (+ (angle (car lst) (cadr lst)) (setq r0 pi2)) r2 (+ (angle (car lst) (cadr lst)) (setq r3 pi2)))
(setq r (+ (angle (car lst) (cadr lst)) (setq r0 3pi2)) r2 (+ (angle (car lst) (cadr lst)) (setq r3 3pi2)))
)
(if (null enttx1)
(progn
(if (null enttx)
(progn
(setq enttx (entget (MakeTxt (polar (car lst) r2 d2) sltex d1 Font1)))
(setq enttx1 enttx)
)
(progn
(entmake (cdr (emod enttx 11 (polar (car lst) r2 d2))))
(setq enttx1 (entget (entlast)))
)
)
)
(entmod (emod enttx1 11 (polar (car lst) r2 d2)))
)
(entmod (reent ent1 (list nil (polar (car lst) r d3) (polar (car lst) r d4)))) ;箭头1
(setq lst (reverse lst) r1 (angle (car lst) (cadr lst)) r (+ r0 r1 pi))
(entmod (reent ent2 (list nil (polar (car lst) r d3) (polar (car lst) r d4)))) ;箭头2
(setq r4 (- r1 r3))
(if enttx2
(entmod (emod enttx2 11 (polar (car lst) r4 d2)))
(progn
(entmake (cdr (emod enttx 11 (polar (car lst) r4 d2))))
(setq enttx2 (entget (entlast)))
)
)
(setq lst (reverse lst))
)
((or (= code 3) (= code 11) (= code 25))
(setq loop nil)
;(_undo2)
(command ".UNDO" "E")
)
)
)
;(setq s (last_ent s))
;(ssnum s sltex "A") ;最后的符号，弹窗再次确认
(if (/= "" (setq txt (getstring (strcat "\n输入剖面号: <" sltex ">"))))
(ModTxtNextE s txt)
);;修改剖面号,YuHB修改
(command ".UNDO" "E")
(princ)
);快速剖面符号----【结束】-----
;;返回：将图元e之后新生成的文字内容修改为txt
(defun ModTxtNextE (e txt / ent)
(if e
(while (setq e (entnext e))
(if (wcmatch (cdr (assoc 0 (setq ent (entget e)))) "TEXT")
(progn
(setq ent (subst (cons 1 txt) (assoc 1 ent) ent))
(entmod ent)
)
)
)
)
(prin1)
)
;取得图元参数值内容----------（一级）-------
;;(setq h (dxf1 ent 40))
; ent 为实体名或实体entget，
(defun dxf1 (ent i / tmp)
(if (= (type ent) 'ENAME)
(setq ent (entget ent '("*")))
)
(setq tmp (cdr (assoc i ent)))
(if (null tmp)
(cond
((= i 66) 0)
((= i 48) (getvar "celtscale"))
((= i 62) 256)
((= i 370) (setq tmp -1))
((= i 6) "ByLayer")
)
tmp
)
)
;(一级)====A-Z递增===取最大字符========
(defun slquzf ()
(if (setq ss (ssget "X" (list '(0 . "TEXT") '(1 . "[A-Z]") '(-3 ("POQIR")))))
(progn
(setq lst '())
(repeat (setq i (sslength ss))
(setq lst (cons (dxf1 (ssname ss (setq i (1- i))) 1) lst))
)
(setq sltex (chr (1+ (ascii (car (vl-sort lst '>))))))
)
(setq sltex "A")
)
)
(defun MakeTxt (pt sltex h font)
(regapp "POQIR")
(entmake (list '(0 . "TEXT") '(62 . 3) (cons 7 font) (cons 10 pt) (cons 40 h) (cons 1 sltex) '(41 . 0.7) '(72 . 1) (cons 11 pt) '(73 . 2)
(list -3 (list "POQIR" (cons 1000 sltex)))
)
)
(entlast)
)
(defun mkpolyline2 (pt1 pt2 h)
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(62 . 4) '(100 . "AcDbPolyline") (cons 90 2) (cons 10 pt1)
(cons 43 h) (cons 10 pt2) (cons 43 h)
)
)
(entlast)
)
(defun mkpolyline3 (pt1 w1 w2 pt2 w3 w4 pt3)
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(62 . 4) '(100 . "AcDbPolyline") '(90 . 3) (cons 10 pt1) (cons 40 w1)
(cons 41 w2) (cons 10 pt2) (cons 40 w3) (cons 41 w4) (cons 10 pt3)
)
)
(entlast)
)
; 按点表顺序更新多段线顶点,无须更换的顶点用nil代替。by:langjs
(defun reent (ent lst / n x)
(mapcar
'(lambda (x)
(setq n (car lst))
(if (= (car x) 10)
(if (/= nil n t (setq lst (cdr lst)))
(cons 10 n)
x
)
x
)
)
ent
)
)
(defun get3ptang (p1 p2 p3 / ans a b an)
(setq ans (list (angle p1 p2) (angle p3 p2))
a (apply
'min
ans
)
b (apply
'max
ans
)
an (- b a)
)
(if (= a (car ans))
an
(- (* 2 pi) an)
)
)
(defun emod (ent i n)
(subst
(cons i n)
(assoc i ent)
ent
)
) |
|
楼主
显身卡
发表于 2022-9-9 09:45