1. ;;;  ===============================================
    2. ;;;   快速剖切线绘制2(带折点)
    3. ;;;   作者：langjs      命令:pq  日期:2014年7月14日
    4. ;;;  ===============================================
    5. (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
    6.                pt1 pt2 pt3 r r0 r1 r2 r3 r4 s ss tex w1 w2 w3 w4 x
    7.             )
    8.   (defun #err002 (s)
    9.     (setq loop nil)
    10.     (command ".UNDO" "E")
    11.     (command ".UNDO" "")
    12.     (setq *error* $orr)
    13.   )
    14.   (defun reent (ent lst / n x)               ; 按点表顺序更新多段线顶点,无须更换的顶点用nil代替。by:langjs
    15.     (mapcar
    16.       '(lambda (x)
    17.          (setq n (car lst))
    18.          (if (= (car x) 10)
    19.            (if (/= nil n t (setq lst (cdr lst)))
    20.              (cons 10 n)
    21.              x
    22.            )
    23.            x
    24.          )
    25.        )
    26.       ent
    27.     )
    28.   )
    29.   (defun emod (ent i n)
    30.     (subst
    31.       (cons i n)
    32.       (assoc i ent)
    33.       ent
    34.     )
    35.   )
    36.   (defun get3ptang (p1 p2 p3 / ans a b an)
    37.     (setq ans (list (angle p1 p2) (angle p3 p2))
    38.           a (apply
    39.               'min
    40.               ans
    41.             )
    42.           b (apply
    43.               'max
    44.               ans
    45.             )
    46.           an (- b a)
    47.     )
    48.     (if (= a (car ans))
    49.       an
    50.       (- (* 2 pi) an)
    51.     )
    52.   )
    53.   (defun mktext (pt tex h)
    54.     (regapp "POQIR")
    55.     (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)
    56.                    (list -3 (list "POQIR" (cons 1000 tex)))
    57.              )
    58.     )
    59.     (entlast)
    60.   )
    61.   (defun mkpolyline2 (pt1 pt2 h)
    62.     (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(62 . 4) '(100 . "AcDbPolyline") (cons 90 2) (cons 10 pt1)
    63.                    (cons 43 h) (cons 10 pt2) (cons 43 h)
    64.              )
    65.     )
    66.     (entlast)
    67.   )
    68.   (defun mkpolyline3 (pt1 w1 w2 pt2 w3 w4 pt3)
    69.     (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(62 . 4) '(100 . "AcDbPolyline") '(90 . 3) (cons 10 pt1) (cons 40 w1)
    70.                    (cons 41 w2) (cons 10 pt2) (cons 40 w3) (cons 41 w4) (cons 10 pt3)
    71.              )
    72.     )
    73.     (entlast)
    74.   )
    75.   (setvar "cmdecho" 0)
    76.   (command ".UNDO" "BE")
    77.   (setq $orr *error*)
    78.   (setq *error* #err002)
    79.   (if (setq ss (ssget "X" (list '(0 . "TEXT") '(1 . "[A-Z]") '(-3 ("POQIR")))))
    80.     (progn
    81.       (setq lst '())
    82.       (repeat (setq i (sslength ss))
    83.         (setq lst (cons (cdr (assoc 1 (entget (ssname ss (setq i (1- i)))))) lst))
    84.       )
    85.       (setq tex (chr (1+ (ascii (car (vl-sort lst '>))))))
    86.     )
    87.     (setq tex "A")
    88.   )
    89.   (if (null bi)
    90.     (setq bi (getvar "DIMSCALE"))
    91.   )
    92.   (while (progn
    93.            (initget "S")
    94.            (if (= (setq s (getpoint (strcat "\n指定起点,或捕捉对齐点,或[设置(S)]: <符号: " tex " >")))
    95.                   "S"
    96.                )
    97.              (progn
    98.                (setq dclname (vl-filename-mktemp "re-dcl-tmp.dcl"))
    99.                (setq filen (open dclname "w"))
    100.                (write-line "RENAME:dialog {" filen)
    101.                (write-line "    label = \"设置\" ;" filen)
    102.                (write-line "        :edit_box {  label = \" 符号内容:\";    key = \"e05\" ;  }" filen)
    103.                (write-line "        :edit_box {  label = \" 文字高度:\";    key = \"e03\" ;  }" filen)
    104.                (write-line "        :edit_box {  label = \" 箭头大小:\";    key = \"e04\" ;  }" filen)
    105.                (write-line "    :row {" filen)
    106.                (write-line "        :button {is_default = true ; key = \"e02\" ; label = \"确认\" ; }" filen)
    107.                (write-line "        :button { is_cancel = true ; key = \"btn_cancle\" ; label = \"取消\" ; }" filen)
    108.                (write-line "         }}" filen)
    109.                (close filen)
    110.                (setq dcl_re (load_dialog dclname))
    111.                (new_dialog "RENAME" dcl_re)
    112.                (set_tile "e03" (rtos (* bi 4) 2 1))
    113.                (set_tile "e04" "同字高")
    114.                (set_tile "e05" tex)
    115.                (action_tile "e02" "(setq bi ( * 0.25 (atof (get_tile \"e03\"))))(done_dialog )")
    116.                (action_tile "e05" "(setq tex (get_tile \"e05\"))(done_dialog )")
    117.                (setq dlg (start_dialog))
    118.                (unload_dialog dcl_re)
    119.                (vl-file-delete dclname)
    120.              )
    121.              (setq pt s)
    122.            )
    123.            (= s "S")
    124.          )
    125.   )
    126.   (if (ssget "c" pt pt)
    127.     (setq pt (getpoint pt "\n指定起点,或<捕捉对齐点>:"))
    128.   )
    129.   (setq lst (list pt))
    130.   (princ "\n指定折点,或<结束选点>:")
    131.   (while (setq pt (getpoint pt))
    132.     (setq lst (cons pt lst))
    133.     (if (= (length lst) 2)
    134.       (mkpolyline2 (cadr lst) (polar (cadr lst) (angle (cadr lst) pt) (* bi 4)) (* bi 0.3))
    135.     )
    136.     (if (>= (length lst) 2)
    137.       (progn
    138.         (if ent
    139.           (progn
    140.             (entmod (reent ent (list (polar (cadr lst) (angle (cadr lst) pt) (* bi 2)))))
    141.             (setq r0 (get3ptang (caddr lst) (cadr lst) (car lst)))
    142.             (if (<= r0 pi)
    143.               (setq r0 (+ pi (* 0.5 r0) (angle (cadr lst) (caddr lst))))
    144.               (setq r0 (+ (* 0.5 r0) (angle (cadr lst) (caddr lst))))
    145.             )
    146.             (if (null enttx)
    147.               (setq enttx (entget (mktext (polar (cadr lst) r0 (* bi 4)) tex (* bi 4))))
    148.               (entmake (cdr (emod enttx 11 (polar (cadr lst) r0 (* bi 4)))))
    149.             )
    150.           )
    151.         )
    152.         (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)))))
    153.       )
    154.     )
    155.   )
    156.   (entmod (reent ent (list nil nil (polar (car lst) (angle (car lst) (cadr lst)) (* bi 4)))))
    157.   (setq ent1 (entget (mkpolyline3 (car lst) 0.0 0.0 (car lst) (* bi 1.3) 0.0 (car lst))))
    158.   (setq ent2 (entget (mkpolyline3 (last lst) 0.0 0.0 (last lst) (* bi 1.3) 0.0 (last lst))))
    159.   (setq loop t
    160.         bu 1
    161.   )
    162.   (princ "\n移动鼠标,指定箭头方向:")
    163.   (while loop
    164.     (setq gr (grread t 15 0)
    165.           code (car gr)
    166.           data (cadr gr)
    167.     )
    168.     (cond
    169.       ((= code 3)
    170.         (if (= bu 1)
    171.           (progn
    172.             (entmake (list '(0 . "TEXT") '(62 . 3) (cons 10 data) (cons 40 (* bi 4)) (cons 1 (strcat tex "-" tex)) '(41 . 0.8)))
    173.             (setq enttx (entget (entlast)))
    174.             (setq ent1 (entget (mkpolyline2 data data (* bi 0.3))))
    175.             (setq ent2 (entget (mkpolyline2 data data 0.0)))
    176.             (setq bu 2)
    177.           )
    178.           (progn
    179.             (setq loop nil)
    180.             (command ".UNDO" "E")
    181.           )
    182.         )
    183.       )
    184.       ((= code 5)
    185.         (cond
    186.           ((= bu 1)
    187.             (setq r0 (get3ptang (cadr lst) (car lst) data))
    188.             (if (<= r0 pi)
    189.               (setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* 0.5 pi)))
    190.                     r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* 0.83 pi)))
    191.               )
    192.               (setq r (+ (angle (car lst) (cadr lst)) (setq r0 (* -0.5 pi)))
    193.                     r2 (+ (angle (car lst) (cadr lst)) (setq r3 (* -0.83 pi)))
    194.               )
    195.             )
    196.             (if (null enttx1)
    197.               (progn
    198.                 (if (null enttx)
    199.                   (progn
    200.                     (setq enttx (entget (mktext (polar (car lst) r2 (* bi 4)) tex (* bi 4))))
    201.                     (setq enttx1 enttx)
    202.                   )
    203.                   (progn
    204.                     (entmake (cdr (emod enttx 11 (polar (car lst) r2 (* bi 4)))))
    205.                     (setq enttx1 (entget (entlast)))
    206.                   )
    207.                 )
    208.               )
    209.               (entmod (emod enttx1 11 (polar (car lst) r2 (* bi 4))))
    210.             )
    211.             (entmod (reent ent1 (list nil (polar (car lst) r (* bi 4)) (polar (car lst) r (* bi 8)))))
    212.             (setq lst (reverse lst)
    213.                   r1 (angle (car lst) (cadr lst))
    214.                   r (+ r0 r1 pi)
    215.             )
    216.             (entmod (reent ent2 (list nil (polar (car lst) r (* bi 4)) (polar (car lst) r (* bi 8)))))
    217.             (setq r4 (- r1 r3))
    218.             (if enttx2
    219.               (progn
    220.                 (entmod (emod enttx2 11 (polar (car lst) r4 (* bi 4))))
    221.               )
    222.               (progn
    223.                 (entmake (cdr (emod enttx 11 (polar (car lst) r4 (* bi 4)))))
    224.                 (setq enttx2 (entget (entlast)))
    225.               )
    226.             )
    227.             (setq lst (reverse lst))
    228.           )
    229.           ((= bu 2)
    230.             (entmod (emod enttx 10 data))
    231.             (setq p1 (car (textbox enttx)))
    232.             (setq p2 (cadr (textbox enttx)))
    233.             (entmod (reent ent1 (list (list (+ (car data) (car p1)) (- (cadr data) bi)) (list (+ (car data) (car p2)) (-
    234.                                                                                                                          (cadr data)
    235.                                                                                                                          bi
    236.                                                                                                                       )
    237.                                                                                         )
    238.                                 )
    239.                     )
    240.             )
    241.             (entmod (reent ent2 (list (list (+ (car data) (car p1)) (- (cadr data) (* 1.7 bi))) (list (+ (car data) (car p2))
    242.                                                                                                       (- (cadr data) (* 1.7 bi))
    243.                                                                                                 )
    244.                                 )
    245.                     )
    246.             )
    247.           )
    248.         )
    249.       )
    250.       ((or
    251.          (= code 11)
    252.          (= code 25)
    253.        )
    254.         (setq loop nil)
    255.         (command ".UNDO" "E")
    256.       )
    257.     )
    258.   )
    259.   (setq *error* $orr)
    260.   (princ)
    261. )

    3333.gif