谢谢分享源码。 牛啊牛啊！大佬厉害 cq4920 发表于 2023-6-15 10:05
老大，这里有个问题，横矩形生成的文字是以长边来的，竖矩形生成的文字才是以短边来的，能不能改成不管横竖都是以短边来命名的？ 本帖最后由 cq4920 于 2023-6-15 20:54 编辑
37902505 发表于 2023-6-15 15:14
老大，这里有个问题，横矩形生成的文字是以长边来的，竖矩形生成的文字才是以短边来的，能不能改成不管横 ...
(defun c:rect (/ pt1 pt2 width height)
(if (setq pt1 (getpoint "\n指定插入点: "))
(progn
(setq pt2 (getcorner pt1 "指定对角点"))
(command "RECTANG" pt1 pt2)
(command "CHPROP" (entlast) "" "LA" "EQUIP_消防" "")
(command "-bhatch" "p" "stars"10 180 "s" (entlast) "" "")
(command "CHPROP" (entlast) """LA" "EQUIP_消防填充" "")
(setq k(rtos (abs (- (car pt1) (car pt2))))
n(rtos (abs (- (cadr pt1) (cadr pt2)))))
(if (> n k)
(setq n k)
)
(setq txt (strcat "XF" n " F"))
(setq pt-xz-y (center-max-y pt1 pt2))
(setq pt3 (list (car pt1) (cadr pt2)))
(entmake (list '(0 . "TEXT") (cons 1 txt) (cons 11 pt-xz-y) (cons 10 pt2)
(cons 40 150)(cons 62 3)(cons 72 1)(cons 73 1)))
(command "CHPROP" (entlast) """LA" "EQUIP_消防文字" "")
)
)
)
(defun center-max-y (pt1 pt2)
(setq x-center (/ (+ (car pt1) (car pt2)) 2.0)
y-max (max (cadr pt1) (cadr pt2)))
(list x-center y-max))
有时候后会出错
cq4920 发表于 2023-6-15 20:43
(defun c:rect (/ pt1 pt2 width height)
(if (setq pt1 (getpoint "\n指定插入点: "))
...
这个不错了，只是都是以长边命名，不是以短边命名。 本帖最后由 yefei812678 于 2023-12-29 11:19 编辑
cq4920 发表于 2023-6-15 20:43
(defun c:rect (/ pt1 pt2 width height)
(if (setq pt1 (getpoint "\n指定插入点: "))
...
能不能弄一个，画完矩形后打开填充界面选择填充样式后直接填充 cq4920 发表于 2023-6-15 10:05
能不能帮我改下这个 在你的基础上 我加个两个填充 能不能添加个选择
(defun c:tcc (/ pt1 pt2 width height)
(if (setq pt1 (getpoint "\n指定插入点: "))
(progn
(setq pt2 (getcorner pt1 "指定对角点"))
(command "RECTANG" pt1 pt2)
(SETQ PT1 (ENTLAST))
(command "-bhatch"
"p"
"平面_石材1_比例1【YBC】"
0.5
45
"s"
(entlast)
""
""
)
(command "-bhatch"
"p"
"立面_木饰面1_90度_比例600【YBC】"
600
90
"s"
(entlast)
""
""
)
(ENTDEL PT1)
)
)
)
(defun c:tt ()
"画指定宽度矩形并填充"
(setq ll (getdist "\n矩形长度<1200>: "))
(or ll (setq ll 1200.))
(setq ww (getdist "\n矩形宽度<300>: "))
(or ww (setq ww 300.))
(setq th (getdist "\n矩形字高<100>: "))
(or th (setq th 100.))
(setvar "hpname" "STARS")
(setvar "HPSCALE" 10)
(setvar "hpang" 0)
(while (setq p0 (getpoint "\n中心点<退出>: "))
(setq p1 (mapcar '+ p0 (list (* ll -0.5) (* ww -0.5)))
p2 (mapcar '+ p0 (list (* ll 0.5) (* ww 0.5)))
)
(command "rectang" "non" p1 "non" p2)
(setq s1 (entlast))
(command "-hatch" "s" s1 "" "")
(setq tx (strcat "XF" (rtos ww 2 0) " F"))
(setq pt (mapcar '+ p0 (list 0 (+ (* ww 0.5) (* th 0.75)))))
(command "text" "j" "mc" "non" pt th 0 tx)
)
(princ)
)
(defun c:tt ()
"画指定宽度矩形并填充"
(defun udist (bit kwd msg def bpt / inp)
(if def
(setq msg(strcat"\n"msg"<"(rtos def)">: ")
bit(* 2(fix(/ bit 2)))
)
(setq msg(strcat"\n"msg": "))
)
(initget bit kwd)
(setq inp(if bpt(getdist msg bpt)(getdist msg)))
(if inp inp def)
)
(or ll (setq ll 1200.))
(or ww (setq ww 300.))
(or th (setq th 100.))
(setq ll (Udist 7 "" "矩形长度<输入或鼠标直接量取>" ll nil))
(setq ww (Udist 7 "" "矩形宽度<输入或鼠标直接量取>" ww nil))
(setq th (Udist 7 "" "字高<输入或鼠标直接量取>" th nil))
(setvar "hpname" "STARS")
(setvar "HPSCALE" 10)
(setvar "hpang" 0)
(while (setq p0 (getpoint "\n中心点<退出>: "))
(setq p1 (mapcar '+ p0 (list (* ll -0.5) (* ww -0.5)))
p2 (mapcar '+ p0 (list (* ll 0.5) (* ww 0.5)))
)
(command "rectang" "non" p1 "non" p2)
(setq s1 (entlast))
(command "-hatch" "s" s1 "" "")
(setq tx (strcat "XF" (rtos ww 2 0) " F"))
(setq pt (mapcar '+ p0 (list 0 (+ (* ww 0.5) (* th 0.75)))))
(command "text" "j" "mc" "non" pt th 0 tx)
)
(princ)
)
页:
1
[2]