[编程交流] 倒角程序，需要hel

(defun c:dj ()
       (setq height 2.5)
        (if (setq judge (getreal "Input text height（Default 2.5）"))
             (setq height judge)                
        )
       (setq messege (entsel))
       (setq ent (entget (car messege)))
        (setq select_point (cadr messege))
        (if (equal (cdr (assoc 0 ent)) "LINE" )
            (setq daojiao (chfd ))
                (progn 
                   (setq daojiao (reduce ent select_point))
           )                           
        )
        ;(princ daojiao)
        (setq point_x (car (caddr daojiao)) point_y (cadr (caddr daojiao))  x1 (car point_x) y1 (cadr point_x) x2 (car point_y) y2 (cadr point_y))
        (setq le_point (list (* 0.5 (+ x1 x2)) (* 0.5 (+ y1 y2)) ))
       (setq c1 (car daojiao) c2 (cadr daojiao))
        (if (= (rtos c1 2 1) (rtos c2 2 1))
            (setq c (strcat "C" (rtos c1 2 1)))
                (setq c (strcat (rtos c1 2 1) "*" (rtos c2 2 1) ))
        )
        (princ c)
        (princ le_point)
        (princ height)
       (bz c le_point height)
       ;(command "leader"  le_point pause pause "" "" "n")
        ;(setq ent (entget (entlast)))
        ;(le ent c height)
)
(defun bz (txt1 p height / *error* name1 name2 name3)
 (defun *error* (msg) ;
   (entdel name1) (entdel name2) (if name3 (entdel name3))
   (princ "err: ")(princ msg)
  ) ;
  
 (setq ty (getvar "TEXTSTYLE") kd3 0)
 (setq kd1 (caadr (textbox (list '(0 . "text")(cons 1 txt1)(cons 40 height)(cons 41 0.7)(cons 7 ty)))))
 (setq kd2 (caadr (textbox (list '(0 . "text")(cons 1 "lyt love lhl")(cons 40 height)(cons 41 0.7)(cons 7 ty)))))
  
 (setq kd (max kd1 kd2) kd (+ kd 50))
 ;(setq p (getpoint "\nSpecify the basis points:"))
 (setq pd t)
 (while pd
   (setq gr (grread t 4 1) mode (car gr) pt (cadr gr))
   (if (= kd3 0) (setq kd kd1))
   (if (and (listp pt) (>= (car pt) (car p))) (progn
     (setq p0 (polar pt 0 kd))
     (setq p1 (polar pt 0 (/ (- kd kd1) 2)) p1 (polar p1 (angtof "90") (* 0.2 height)))
     (setq p2 (polar pt 0 (/ (- kd kd2) 2)) p2 (polar p2 (angtof "270") 350)))
)
   (if (and (listp pt) (< (car pt) (car p))) (progn
     (setq p0 (polar pt pi kd))
     (setq p1 (polar p0 0 (/ (- kd kd1) 2)) p1 (polar p1 (angtof "90") (* 0.2 height)))
     (setq p2 (polar p0 0 (/ (- kd kd2) 2)) p2 (polar p2 (angtof "270") 350)))
)
   (if (= mode 5) (progn
     (if name1 (entdel name1))
     (entmake (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 3)
       (cons 10 p)(cons 10 pt)(cons 10 p0)))
     (setq name1 (entlast))
     (if name2 (entdel name2))
     (entmake (list '(0 . "text")(cons 1 txt1)(cons 40 height)(cons 41 0.7)(cons 10 p1)(cons 7 ty)))
     (setq name2 (entlast))
     (if name3 (entdel name3))
     (if (= kd3 1) (entmake (list '(0 . "text")(cons 1 txt2)(cons 40 height)(cons 41 0.7)(cons 10 p2)(cons 7 ty))))
     (if (= kd3 1) (setq name3 (entlast))))
)
   (if (= mode 3) (setq pd nil))
   (if (or (= mode 2) (= mode 25)) (progn (setq pd nil) (entdel name1) (entdel name2) (if name3 (entdel name3))))
 )
 
)
(defun le (ent choice height)
       (setq points '())
    (mapcar '(lambda (x) 
                       (cond
                                ((= 10 (car x)) (setq points (cons (cdr x) points)))                                           
                                       )
               )
                   ent
    )
    (setq point_end   (car  points))
    (setq point_start (cadr points))
    (if (> (- (car point_end) (car point_start)) 0)
        (progn
                   (setq point (list (+ (car point_end)  (* 0.7 height)) (- (cadr point_end) (* 0.5 height))))
               (command "text" point height 0 choice )
            )
           (progn 
                   (setq point (list (- (car point_end) (* 0.7 height) ) (- (cadr point_end) (* 0.5 height))))
               (command "text" point height 0 choice )
                  (setq entname (entlast))
                   (setq ent (entget entname))
                   (entmod
                         (mapcar '(lambda ( x) 
                                               (cond 
                                                      ((= (car x) 72) (cons (car x)  2))
                                                                              ((= (car x) 11) (cons (car x)  point))
                                                                              (t x)
                                                            ) 
                                                    )
                                       ent
                              )
                    )           
            )
    )
       (setq text_point (mapcar '* (mapcar '+ point_end point_start) '(0.5 0.5 0.5)))
        (setq height_modify  (list 0 (* 0.2 height) 0 ) )
        (setq text_point (mapcar '+  text_point height_modify))
    (setq ent (entget (entlast)))
        (entmod
                         (mapcar '(lambda ( x) 
                                               (cond 
                                                      ((= (car x) 72) (cons (car x)  1))
                                                                              ((= (car x) 11) (cons (car x)  text_point))
                                                                              (t x)
                                                            ) 
                                                    )
                                       ent
                              )
        )
)
(defun reduce (ent select_point / daojiao1 point0 point1 point2 point3 x y x1 x2 y1 y2)
       (setq points '())
        (setq i 1)
        (setq x (car select_point) y (cadr select_point))
       (mapcar '(lambda (x)  (cond
                                     ((= 10 (car x))  (setq points (cons (cdr x) points)) )                
                                 ) 
                       )
                         ent
        )
        (setq x (car select_point) y (cadr select_point))
    (setq add_point1 (car points))
        (setq add_point2 (cadr points))
        (setq points (reverse points))
        (setq add_point3 (car points))
        (setq points (cons add_point1 points))
        (setq points (cons add_point2 points))
        (setq points (reverse points))
        (setq points (cons add_point3 points))
        (while (< i (- (length points) 2) )
               (setq point1 (nth i points))
                   (setq point2 (nth (+ i 1) points))
                   (setq x1 (car point1) y1 (cadr point1) x2 (car point2) y2 (cadr point2))
                   (if (and (or (and (< x x1) (> x x2)) (and (< x x2) (> x x1))) (or (and (< y y1) (> y y2)) (and (< y y2) (> y y1))))
                       (setq j i i (length points))
                   )
                   (setq i (+ i 1))
        )
        
        (setq point0 (nth (- j 1) points) point3 (nth (+ j 2) points))
        (setq default_color (getvar "cecolor"))
        (command "color" 1 "")
        (command "line" point0 point1 "")
        (setq ent1 (entlast))
        (command "line" point1 point2 "")
        (setq ent2 (entlast))
        (command "line" point2 point3 "")
        (setq ent3 (entlast))
        (setq daojiao1 (chfd))
        (entdel ent1 )
        (entdel ent2 )
        (entdel ent3 )
        (command "color" default_color "")
        (setq daojiao1 daojiao1)
)
(defun chfd (/ _dxf _para _valid a typ obj p1 p2 intrpt)
(Defun _dxf (e dx) (cdr (assoc dx (entget e))))
(defun _para (o p)
   (vlax-curve-getparamatpoint
     o
     (vlax-curve-getClosestPointTo o p )
   )
 )
(defun _valid   (e typ / e)
     (if (wcmatch (Setq v (_dxf e 0)) typ)
           v))
     (if (and (setq a (entsel "\nSelect Chamfered segment: "))
              (Setq typ (_valid (setq obj (car a))
                                "LWPOLYLINE,LINE")))
        (if (eq typ "LINE")
                   (progn
                                      (command "change" obj "" "p" "c" 3 "")
                         (while (not (And
                                           (setq obj2 (car  (entsel  "\nSelect another segment: ")))
                                                                                (not (command "change" obj2 "" "p" "c" 3 ""))
                                           (setq obj3 (car  (entsel  "\nAnd another: ")))
                                                                                (not (command "change" obj3 "" "p" "c" 3 ""))
                                           (_valid obj2 "LINE")
                                           (_valid obj3 "LINE"))
                                     )
                          )
                         (setq intrpt (inters (_dxf obj2 10)
                                              (_dxf obj2 11)
                                              (_dxf obj3 10)
                                              (_dxf obj3 11)
                                              nil))
                         (Setq p1 (_dxf obj 10) p2 (_dxf obj 11))
                         )
                (progn
                             (setq prm1 (_para obj (cadr a)))
                        (setq pts (mapcar 'cdr
                                          (vl-remove-if-not
                                                '(lambda (k)
                                                       (= (car k) 10)
                                                       )
                                                (entget obj)
                                                )
                                          )
                              )
                  (setq inbetween (vl-some '(lambda        (j k)
                                          (if (< (_para obj j) prm1 (_para obj k))
                                            (list j k)
                                          )
                                        )
                                       pts
                                       (cdr pts)
                              )
                  )
                       (and
                        (setq p1 (cadr (member (car inbetween) (reverse pts))))
                        (setq p2 (cadr (member (Cadr inbetween) pts)))
                        (setq intrpt (inters p1  (Car inbetween)
                               p2  (cadr inbetween) nil)
                                )
                               (setq p1 (Car inbetween) p2 (cadr inbetween))
                        )
                   )
                   )(princ "\nNull/Invalid selection")
         
         )
         (if intrpt
                 (print (strcat "<<< "
                         (rtos (distance p1 intrpt) 2 2)
                         "x"
                         (rtos (distance p2 intrpt) 2 2)
                         " >>>"
                 )
          )(princ "\nInvalid data")
             )
        (setq aa (distance p1 intrpt))
        (setq bb (distance p2 intrpt))
        (list aa bb (list p1 p2))
         )

(defun c:chfd (/ _dxf _para _valid a typ obj p1 p2 intrpt)
(Defun _dxf (e dx) (cdr (assoc dx (entget e))))
(defun _para (o p)
   (vlax-curve-getparamatpoint
     o
     (vlax-curve-getClosestPointTo o p)
   )
 )
(defun _valid   (e typ / e)
     (if (wcmatch (Setq v (_dxf e 0)) typ)
           v))
     (if (and (setq a (entsel "\nSelect Chamfered segment: "))
              (Setq typ (_valid (setq obj (car a))
                                "LWPOLYLINE,LINE")))
        (if (eq typ "LINE")
                   (progn
                         (while (not (And
                                           (setq obj2 (car  (entsel  "\nSelect another segment: ")))
                                           (setq obj3 (car  (entsel  "\nAnd another: ")))
                                           (_valid obj2 "LINE")
                                           (_valid obj3 "LINE"))
                                     )
                          )
                         (setq intrpt (inters (_dxf obj2 10)
                                              (_dxf obj2 11)
                                              (_dxf obj3 10)
                                              (_dxf obj3 11)
                                              nil))
                         (Setq p1 (_dxf obj 10) p2 (_dxf obj 11))
                         )
                (progn
                             (setq prm1 (_para obj (cadr a)))
                        (setq pts (mapcar 'cdr
                                          (vl-remove-if-not
                                                '(lambda (k)
                                                       (= (car k) 10)
                                                       )
                                                (entget obj)
                                                )
                                          )
                              )
                  (setq inbetween (vl-some '(lambda        (j k)
                                          (if (< (_para obj j) prm1 (_para obj k))
                                            (list j k)
                                          )
                                        )
                                       pts
                                       (cdr pts)
                              )
                  )
                       (and
                        (setq p1 (cadr (member (car inbetween) (reverse pts))))
                        (setq p2 (cadr (member (Cadr inbetween) pts)))
                        (setq intrpt (inters p1  (Car inbetween)
                               p2  (cadr inbetween) nil)
                                )
                               (setq p1 (Car inbetween) p2 (cadr inbetween))
                        )
                   )
                   )(princ "\nNull/Invalid selection")
         
         )
         (if intrpt
                 (print (strcat "<<< "
                         (rtos (distance p1 intrpt) 2 2)
                         "x"
                         (rtos (distance p2 intrpt) 2 2)
                         " >>>"
                 )
          )(princ "\nInvalid data")
             )(princ)
         )