快速剖切线绘制2(带折点)

langjs

有网友跟我要这个，就修改了一下传上来。


;;;  ===============================================
;;;   快速剖切线绘制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)
)

t18-13nil

尘缘一生 发表于 2020-11-12 17:39
根据绘图建筑规范，画的不是箭头，怎么把箭头去掉？

这是搞机械的标准化画法，mkpolyline3里面去掉40，41就是没有箭头了

尘缘一生

根据绘图建筑规范，画的不是箭头，怎么把箭头去掉？

zhangrunze

学习了~感谢分享~
蛮不错呢~

zkq1212

好东西，设置带一个对话框就更好了

langjs

已经带了对话框。另外院长，单位破局域网传不了图。

zkq1212

langjs 发表于 2014-7-2 14:14
已经带了对话框。另外院长，单位破局域网传不了图。

不好意思，没说清楚。应该是右键选项

lucas_3333

郎大师，非常感谢！！！

yaokui25

郎大师出品，必须顶一个

xhq1954425

可以再增加一个选项放置A——A更好……
箭头位置确定后可用join 把它跟短线合并

发个小图表示谢意

enn09

郎大师出品，必须顶一个~~对于我这个专业作用不大的说~~

yoyoho

感谢 langjs  分享程序!

adc

看到个类似的http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108041