社区 › AutoLISP/Visual LISP 编程技术 › 求：修改下郎大师的【快速剖切】

尘缘一生 发表于 2019-7-29 18:07:50

求：修改下郎大师的【快速剖切】

本帖最后由 尘缘一生 于 2019-7-29 18:24 编辑

郎大师有段代码：快速剖切。原帖地址如下：

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=110581&highlight=%BF%EC%CB%D9

代码原帖有：希望修改如下效果：

左侧为源码效果，右侧为目的结果



(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 . "") '(-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)
)
       文字写在箭头侧面，这在图纸很多位置，不行，也不美观，还需要移动修改，对于老一辈绘图人来说，心中极其的别扭！尝试修改2天，无奈水平有限，不成功；
          另外：像这种只有一段情况，应该去掉箭头，以适应建筑专业，这个倒是好办到，就不劳烦大家了。


         题外话： 请大家看看PKPM 的 MODIFY.EXE   看看人家里面怎么作的，不要看天正，盈建科，探索者等，作就做个完美。
      

start4444 发表于 2019-7-30 14:01:52

应该找到字体的基点修改就行了，我改了r3这个角度还有放置点的距离，我试了下可以

(defun c:tt5 (/ 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 . "") '(-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.5 pi)))
                                                        )
                                                        (setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* -0.5 pi)))
                                                                r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* -0.5 pi)))
                                                        )
                                                )
                                                (if (null enttx1)
                                                        (progn
                                                                (if (null enttx)
                                                                        (progn
                                                                                (setq enttx (entget (mktext (polar (car lst) r2 (* bi 13)) tex (* bi 4))))
                                                                                (setq enttx1 enttx)
                                                                        )
                                                                        (progn
                                                                                (entmake (cdr (emod enttx 11 (polar (car lst) r2 (* bi 13)))))
                                                                                (setq enttx1 (entget (entlast)))
                                                                        )
                                                                )
                                                        )
                                                        (entmod (emod enttx1 11 (polar (car lst) r2 (* bi 13))))
                                                )
                                                (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 13))))
                                                        )
                                                        (progn
                                                                (entmake (cdr (emod enttx 11 (polar (car lst) r4 (* bi 13)))))
                                                                (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)
)

start4444 发表于 2019-7-31 17:31:28

start4444 发表于 2019-7-30 14:01
应该找到字体的基点修改就行了，我改了r3这个角度还有放置点的距离，我试了下可以

(defun c:tt5 (/ a an ...

是的，那个字母的基点就是由粗线端点由极坐标算出来的，跟角度有关

mokson 发表于 2019-7-31 17:52:14

这个CAD本身有得设置的呀。

zj20190405 发表于 2020-9-13 19:47:19

本帖最后由 zj20190405 于 2020-9-13 19:48 编辑

start4444 发表于 2019-7-31 17:31
是的，那个字母的基点就是由粗线端点由极坐标算出来的，跟角度有关
大佬，有没有办法把，所生成符号和线段做成一个组，这样改图容易选中自动，本身生成出来的是分散，不好移动

e2002 发表于 2020-9-13 20:17:00

zj20190405 发表于 2020-9-13 19:47
大佬，有没有办法把，所生成符号和线段做成一个组，这样改图容易选中自动，本身生成出来的是分散，不好移 ...

如果是我来做这个事，我会优先使用动态块。这样既简单有能达到如你所需的整体性。

不是什么都要去写程序来解决的。

zj20190405 发表于 2021-4-22 23:50:48

start4444 发表于 2019-7-31 17:31
是的，那个字母的基点就是由粗线端点由极坐标算出来的，跟角度有关

大哥有时间吗，能把剖切的箭头，多段线弄成一个整体吗，改图的时候比较好修改

查看完整版本: 求：修改下郎大师的【快速剖切】