本帖最后由 langjs 于 2014-7-14 20:47 编辑
有网友跟我要这个，就修改了一下传上来。
;;; ===============================================
;;; 快速剖切线绘制2(带折点)
;;; 作者：langjs 命令:pq 日期:2014年7月14日
;;; ===============================================
(defun c:pq (/ a an ans b bi bu code data dcl_re dclname dlg ent ent1 ent2 enttx enttx1 enttx2 filen gr h i loop lst n p1 p2 p3 pt
pt1 pt2 pt3 r r0 r1 r2 r3 r4 s ss tex w1 w2 w3 w4 x
)
(defun #err002 (s)
(setq loop nil)
(command ".UNDO" "E")
(command ".UNDO" "")
(setq *error* $orr)
)
(defun reent (ent lst / n x) ; 按点表顺序更新多段线顶点,无须更换的顶点用nil代替。by:langjs
(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 emod (ent i n)
(subst
(cons i n)
(assoc i ent)
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 mktext (pt tex h)
(regapp "POQIR")
(entmake (list '(0 . "TEXT") '(62 . 3) (cons 10 pt) (cons 40 h) (cons 1 tex) '(41 . 0.8) '(72 . 1) (cons 11 pt) '(73 . 2)
(list -3 (list "POQIR" (cons 1000 tex)))
)
)
(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)
)
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq $orr *error*)
(setq *error* #err002)
(if (setq ss (ssget "X" (list '(0 . "TEXT") '(1 . "[A-Z]") '(-3 ("POQIR")))))
(progn
(setq lst '())
(repeat (setq i (sslength ss))
(setq lst (cons (cdr (assoc 1 (entget (ssname ss (setq i (1- i)))))) lst))
)
(setq tex (chr (1+ (ascii (car (vl-sort lst '>))))))
)
(setq tex "A")
)
(if (null bi)
(setq bi (getvar "DIMSCALE"))
)
(while (progn
(initget "S")
(if (= (setq s (getpoint (strcat "\n指定起点,或捕捉对齐点,或[设置(S)]: <符号: " tex " >")))
"S"
)
(progn
(setq dclname (vl-filename-mktemp "re-dcl-tmp.dcl"))
(setq filen (open dclname "w"))
(write-line "RENAME:dialog {" filen)
(write-line " label = \"设置\" ;" filen)
(write-line " :edit_box { label = \" 符号内容:\"; key = \"e05\" ; }" filen)
(write-line " :edit_box { label = \" 文字高度:\"; key = \"e03\" ; }" filen)
(write-line " :edit_box { label = \" 箭头大小:\"; key = \"e04\" ; }" filen)
(write-line " :row {" filen)
(write-line " :button {is_default = true ; key = \"e02\" ; label = \"确认\" ; }" filen)
(write-line " :button { is_cancel = true ; key = \"btn_cancle\" ; label = \"取消\" ; }" filen)
(write-line " }}" filen)
(close filen)
(setq dcl_re (load_dialog dclname))
(new_dialog "RENAME" dcl_re)
(set_tile "e03" (rtos (* bi 4) 2 1))
(set_tile "e04" "同字高")
(set_tile "e05" tex)
(action_tile "e02" "(setq bi ( * 0.25 (atof (get_tile \"e03\"))))(done_dialog )")
(action_tile "e05" "(setq tex (get_tile \"e05\"))(done_dialog )")
(setq dlg (start_dialog))
(unload_dialog dcl_re)
(vl-file-delete dclname)
)
(setq pt s)
)
(= s "S")
)
)
(if (ssget "c" pt pt)
(setq pt (getpoint pt "\n指定起点,或<捕捉对齐点>:"))
)
(setq lst (list pt))
(princ "\n指定折点,或<结束选点>:")
(while (setq pt (getpoint pt))
(setq lst (cons pt lst))
(if (= (length lst) 2)
(mkpolyline2 (cadr lst) (polar (cadr lst) (angle (cadr lst) pt) (* bi 4)) (* bi 0.3))
)
(if (>= (length lst) 2)
(progn
(if ent
(progn
(entmod (reent ent (list (polar (cadr lst) (angle (cadr lst) pt) (* bi 2)))))
(setq r0 (get3ptang (caddr lst) (cadr lst) (car lst)))
(if (<= r0 pi)
(setq r0 (+ pi (* 0.5 r0) (angle (cadr lst) (caddr lst))))
(setq r0 (+ (* 0.5 r0) (angle (cadr lst) (caddr lst))))
)
(if (null enttx)
(setq enttx (entget (mktext (polar (cadr lst) r0 (* bi 4)) tex (* bi 4))))
(entmake (cdr (emod enttx 11 (polar (cadr lst) r0 (* bi 4)))))
)
)
)
(setq ent (entget (mkpolyline3 pt (* bi 0.3) (* bi 0.3) pt (* bi 0.3) (* bi 0.3) (polar pt (angle pt (cadr lst)) (* bi 2)))))
)
)
)
(entmod (reent ent (list nil nil (polar (car lst) (angle (car lst) (cadr lst)) (* bi 4)))))
(setq ent1 (entget (mkpolyline3 (car lst) 0.0 0.0 (car lst) (* bi 1.3) 0.0 (car lst))))
(setq ent2 (entget (mkpolyline3 (last lst) 0.0 0.0 (last lst) (* bi 1.3) 0.0 (last lst))))
(setq loop t
bu 1
)
(princ "\n移动鼠标,指定箭头方向:")
(while loop
(setq gr (grread t 15 0)
code (car gr)
data (cadr gr)
)
(cond
((= code 3)
(if (= bu 1)
(progn
(entmake (list '(0 . "TEXT") '(62 . 3) (cons 10 data) (cons 40 (* bi 4)) (cons 1 (strcat tex "-" tex)) '(41 . 0.8)))
(setq enttx (entget (entlast)))
(setq ent1 (entget (mkpolyline2 data data (* bi 0.3))))
(setq ent2 (entget (mkpolyline2 data data 0.0)))
(setq bu 2)
)
(progn
(setq loop nil)
(command ".UNDO" "E")
)
)
)
((= code 5)
(cond
((= bu 1)
(setq r0 (get3ptang (cadr lst) (car lst) data))
(if (<= r0 pi)
(setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* 0.5 pi)))
r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* 0.83 pi)))
)
(setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* -0.5 pi)))
r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* -0.83 pi)))
)
)
(if (null enttx1)
(progn
(if (null enttx)
(progn
(setq enttx (entget (mktext (polar (car lst) r2 (* bi 4)) tex (* bi 4))))
(setq enttx1 enttx)
)
(progn
(entmake (cdr (emod enttx 11 (polar (car lst) r2 (* bi 4)))))
(setq enttx1 (entget (entlast)))
)
)
)
(entmod (emod enttx1 11 (polar (car lst) r2 (* bi 4))))
)
(entmod (reent ent1 (list nil (polar (car lst) r (* bi 4)) (polar (car lst) r (* bi 8)))))
(setq lst (reverse lst)
r1 (angle (car lst) (cadr lst))
r (+ r0 r1 pi)
)
(entmod (reent ent2 (list nil (polar (car lst) r (* bi 4)) (polar (car lst) r (* bi 8)))))
(setq r4 (- r1 r3))
(if enttx2
(progn
(entmod (emod enttx2 11 (polar (car lst) r4 (* bi 4))))
)
(progn
(entmake (cdr (emod enttx 11 (polar (car lst) r4 (* bi 4)))))
(setq enttx2 (entget (entlast)))
)
)
(setq lst (reverse lst))
)
((= bu 2)
(entmod (emod enttx 10 data))
(setq p1 (car (textbox enttx)))
(setq p2 (cadr (textbox enttx)))
(entmod (reent ent1 (list (list (+ (car data) (car p1)) (- (cadr data) bi)) (list (+ (car data) (car p2)) (-
(cadr data)
bi
)
)
)
)
)
(entmod (reent ent2 (list (list (+ (car data) (car p1)) (- (cadr data) (* 1.7 bi))) (list (+ (car data) (car p2))
(- (cadr data) (* 1.7 bi))
)
)
)
)
)
)
)
((or
(= code 11)
(= code 25)
)
(setq loop nil)
(command ".UNDO" "E")
)
)
)
(setq *error* $orr)
(princ)
)
网友答:
这是搞机械的标准化画法，mkpolyline3里面去掉40，41就是没有箭头了网友答: 根据绘图建筑规范，画的不是箭头，怎么把箭头去掉？网友答: 学习了~感谢分享~
蛮不错呢~网友答: 好东西，设置带一个对话框就更好了网友答: 已经带了对话框。另外院长，单位破局域网传不了图。
网友答:
不好意思，没说清楚。应该是右键选项网友答: 郎大师，非常感谢！！！
网友答:
郎大师出品，必须顶一个
网友答:
本帖最后由 xhq1954425 于 2014-7-2 18:01 编辑
可以再增加一个选项放置A——A更好……
箭头位置确定后可用join 把它跟短线合并
发个小图表示谢意
网友答: 郎大师出品，必须顶一个~~对于我这个专业作用不大的说~~网友答: 感谢 langjs 分享程序!网友答: 看到个类似的http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108041
有网友跟我要这个，就修改了一下传上来。
;;; ===============================================
;;; 快速剖切线绘制2(带折点)
;;; 作者：langjs 命令:pq 日期:2014年7月14日
;;; ===============================================
(defun c:pq (/ a an ans b bi bu code data dcl_re dclname dlg ent ent1 ent2 enttx enttx1 enttx2 filen gr h i loop lst n p1 p2 p3 pt
pt1 pt2 pt3 r r0 r1 r2 r3 r4 s ss tex w1 w2 w3 w4 x
)
(defun #err002 (s)
(setq loop nil)
(command ".UNDO" "E")
(command ".UNDO" "")
(setq *error* $orr)
)
(defun reent (ent lst / n x) ; 按点表顺序更新多段线顶点,无须更换的顶点用nil代替。by:langjs
(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 emod (ent i n)
(subst
(cons i n)
(assoc i ent)
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 mktext (pt tex h)
(regapp "POQIR")
(entmake (list '(0 . "TEXT") '(62 . 3) (cons 10 pt) (cons 40 h) (cons 1 tex) '(41 . 0.8) '(72 . 1) (cons 11 pt) '(73 . 2)
(list -3 (list "POQIR" (cons 1000 tex)))
)
)
(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)
)
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq $orr *error*)
(setq *error* #err002)
(if (setq ss (ssget "X" (list '(0 . "TEXT") '(1 . "[A-Z]") '(-3 ("POQIR")))))
(progn
(setq lst '())
(repeat (setq i (sslength ss))
(setq lst (cons (cdr (assoc 1 (entget (ssname ss (setq i (1- i)))))) lst))
)
(setq tex (chr (1+ (ascii (car (vl-sort lst '>))))))
)
(setq tex "A")
)
(if (null bi)
(setq bi (getvar "DIMSCALE"))
)
(while (progn
(initget "S")
(if (= (setq s (getpoint (strcat "\n指定起点,或捕捉对齐点,或[设置(S)]: <符号: " tex " >")))
"S"
)
(progn
(setq dclname (vl-filename-mktemp "re-dcl-tmp.dcl"))
(setq filen (open dclname "w"))
(write-line "RENAME:dialog {" filen)
(write-line " label = \"设置\" ;" filen)
(write-line " :edit_box { label = \" 符号内容:\"; key = \"e05\" ; }" filen)
(write-line " :edit_box { label = \" 文字高度:\"; key = \"e03\" ; }" filen)
(write-line " :edit_box { label = \" 箭头大小:\"; key = \"e04\" ; }" filen)
(write-line " :row {" filen)
(write-line " :button {is_default = true ; key = \"e02\" ; label = \"确认\" ; }" filen)
(write-line " :button { is_cancel = true ; key = \"btn_cancle\" ; label = \"取消\" ; }" filen)
(write-line " }}" filen)
(close filen)
(setq dcl_re (load_dialog dclname))
(new_dialog "RENAME" dcl_re)
(set_tile "e03" (rtos (* bi 4) 2 1))
(set_tile "e04" "同字高")
(set_tile "e05" tex)
(action_tile "e02" "(setq bi ( * 0.25 (atof (get_tile \"e03\"))))(done_dialog )")
(action_tile "e05" "(setq tex (get_tile \"e05\"))(done_dialog )")
(setq dlg (start_dialog))
(unload_dialog dcl_re)
(vl-file-delete dclname)
)
(setq pt s)
)
(= s "S")
)
)
(if (ssget "c" pt pt)
(setq pt (getpoint pt "\n指定起点,或<捕捉对齐点>:"))
)
(setq lst (list pt))
(princ "\n指定折点,或<结束选点>:")
(while (setq pt (getpoint pt))
(setq lst (cons pt lst))
(if (= (length lst) 2)
(mkpolyline2 (cadr lst) (polar (cadr lst) (angle (cadr lst) pt) (* bi 4)) (* bi 0.3))
)
(if (>= (length lst) 2)
(progn
(if ent
(progn
(entmod (reent ent (list (polar (cadr lst) (angle (cadr lst) pt) (* bi 2)))))
(setq r0 (get3ptang (caddr lst) (cadr lst) (car lst)))
(if (<= r0 pi)
(setq r0 (+ pi (* 0.5 r0) (angle (cadr lst) (caddr lst))))
(setq r0 (+ (* 0.5 r0) (angle (cadr lst) (caddr lst))))
)
(if (null enttx)
(setq enttx (entget (mktext (polar (cadr lst) r0 (* bi 4)) tex (* bi 4))))
(entmake (cdr (emod enttx 11 (polar (cadr lst) r0 (* bi 4)))))
)
)
)
(setq ent (entget (mkpolyline3 pt (* bi 0.3) (* bi 0.3) pt (* bi 0.3) (* bi 0.3) (polar pt (angle pt (cadr lst)) (* bi 2)))))
)
)
)
(entmod (reent ent (list nil nil (polar (car lst) (angle (car lst) (cadr lst)) (* bi 4)))))
(setq ent1 (entget (mkpolyline3 (car lst) 0.0 0.0 (car lst) (* bi 1.3) 0.0 (car lst))))
(setq ent2 (entget (mkpolyline3 (last lst) 0.0 0.0 (last lst) (* bi 1.3) 0.0 (last lst))))
(setq loop t
bu 1
)
(princ "\n移动鼠标,指定箭头方向:")
(while loop
(setq gr (grread t 15 0)
code (car gr)
data (cadr gr)
)
(cond
((= code 3)
(if (= bu 1)
(progn
(entmake (list '(0 . "TEXT") '(62 . 3) (cons 10 data) (cons 40 (* bi 4)) (cons 1 (strcat tex "-" tex)) '(41 . 0.8)))
(setq enttx (entget (entlast)))
(setq ent1 (entget (mkpolyline2 data data (* bi 0.3))))
(setq ent2 (entget (mkpolyline2 data data 0.0)))
(setq bu 2)
)
(progn
(setq loop nil)
(command ".UNDO" "E")
)
)
)
((= code 5)
(cond
((= bu 1)
(setq r0 (get3ptang (cadr lst) (car lst) data))
(if (<= r0 pi)
(setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* 0.5 pi)))
r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* 0.83 pi)))
)
(setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* -0.5 pi)))
r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* -0.83 pi)))
)
)
(if (null enttx1)
(progn
(if (null enttx)
(progn
(setq enttx (entget (mktext (polar (car lst) r2 (* bi 4)) tex (* bi 4))))
(setq enttx1 enttx)
)
(progn
(entmake (cdr (emod enttx 11 (polar (car lst) r2 (* bi 4)))))
(setq enttx1 (entget (entlast)))
)
)
)
(entmod (emod enttx1 11 (polar (car lst) r2 (* bi 4))))
)
(entmod (reent ent1 (list nil (polar (car lst) r (* bi 4)) (polar (car lst) r (* bi 8)))))
(setq lst (reverse lst)
r1 (angle (car lst) (cadr lst))
r (+ r0 r1 pi)
)
(entmod (reent ent2 (list nil (polar (car lst) r (* bi 4)) (polar (car lst) r (* bi 8)))))
(setq r4 (- r1 r3))
(if enttx2
(progn
(entmod (emod enttx2 11 (polar (car lst) r4 (* bi 4))))
)
(progn
(entmake (cdr (emod enttx 11 (polar (car lst) r4 (* bi 4)))))
(setq enttx2 (entget (entlast)))
)
)
(setq lst (reverse lst))
)
((= bu 2)
(entmod (emod enttx 10 data))
(setq p1 (car (textbox enttx)))
(setq p2 (cadr (textbox enttx)))
(entmod (reent ent1 (list (list (+ (car data) (car p1)) (- (cadr data) bi)) (list (+ (car data) (car p2)) (-
(cadr data)
bi
)
)
)
)
)
(entmod (reent ent2 (list (list (+ (car data) (car p1)) (- (cadr data) (* 1.7 bi))) (list (+ (car data) (car p2))
(- (cadr data) (* 1.7 bi))
)
)
)
)
)
)
)
((or
(= code 11)
(= code 25)
)
(setq loop nil)
(command ".UNDO" "E")
)
)
)
(setq *error* $orr)
(princ)
)
网友答:
尘缘一生 发表于 2020-11-12 17:39
根据绘图建筑规范，画的不是箭头，怎么把箭头去掉？
这是搞机械的标准化画法，mkpolyline3里面去掉40，41就是没有箭头了网友答: 根据绘图建筑规范，画的不是箭头，怎么把箭头去掉？网友答: 学习了~感谢分享~
蛮不错呢~网友答: 好东西，设置带一个对话框就更好了网友答: 已经带了对话框。另外院长，单位破局域网传不了图。
网友答:
langjs 发表于 2014-7-2 14:14
已经带了对话框。另外院长，单位破局域网传不了图。
不好意思，没说清楚。应该是右键选项网友答: 郎大师，非常感谢！！！
网友答:
郎大师出品，必须顶一个网友答:
本帖最后由 xhq1954425 于 2014-7-2 18:01 编辑 可以再增加一个选项放置A——A更好……
箭头位置确定后可用join 把它跟短线合并
发个小图表示谢意
网友答: 郎大师出品，必须顶一个~~对于我这个专业作用不大的说~~网友答: 感谢 langjs 分享程序!网友答: 看到个类似的http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108041