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

(defun c:demo (/ chfd data p1 p2 gr)
;;;        Demo for pBe Jan 2014                ;;;
 (defun *error* (msg)
   (command "._undo" "_end")
   (setvar 'cmdecho cmo)(setvar "dimtad" tad) (setvar "dimgap" gap)(setvar "Dimtxt" dtxt)
) ;_ end_defun
(defun chfd (/ _dxf _para _valid a typ obj p1 p2 intrpt P3 P4)
(Defun _dxf (e dx) (cdr (assoc dx (entget e))))
(defun _valid   (e typ / e)
     (if (wcmatch (Setq v (_dxf e 0)) typ)
           v))
(setq cmo (getvar 'cmdecho))
(setvar 'cmdecho 0)  
(command "._undo" "_begin")  
     (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 p3 (_dxf obj 10) p4 (_dxf obj 11)))
          (progn
;;;         Kent Cooper                                                        ;;;
;;;        http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General        ;;;
;;;        /Find-segments-of-polyline/td-p/4785889                                    ;;;
            (defun ptpar (par)
              (reverse
                (cdr
                  (reverse (vlax-curve-getPointAtParam plent par)
                  )
                )
              )
            )
            (setvar "osmode" 0)
            (setq
              plent  (car a)        ; the PolyLine ENTity name
              verts  (cdr (assoc 90 (entget plent)))
                                ; number of VERTiceS
              prepar (fix (vlax-curve-getParamAtPoint
                            plent
                            (osnap (cadr a) "_nea")
                          )
                     )
                                ; PREceding-pick-point vertex's PARameter value
              p1     (ptpar (rem (1- (+ prepar verts)) verts))
              p4     (ptpar prepar)
              p3     (ptpar (rem (1+ prepar) verts))
              p2     (ptpar (rem (+ 2 prepar) verts))
            )                        ; setq
            (setq intrpt (inters p1 p4 p2 p3 nil))
          )
                      )(princ "\nNull/Invalid selection")
         
         )
     (list  P3 P4 
         (if intrpt
                (strcat "<<< "
                         (rtos (distance p3 intrpt) 2 2)
                         "x"
                         (rtos (distance p4 intrpt) 2 2)
                         " >>>"
                 )
           "Invalid data"
             )
         )
)
 
(setq tad (Getvar "dimtad") dtxt (getvar "Dimtxt")
gap (getvar "dimgap"))
(if (not height) (setq height 1.00))
(setq height (cond
                      ((getreal
                             (strcat "\nEnter text height <"
                                     (rtos height 2 2)
                                     ">: ")))
                      (height)))
 
        
(if (eq (last (setq data (chfd))) "Invalid data")
           (princ "\nNo Data to process")
              (progn
               (setvar "dimtad" 0)(setvar "dimgap" -1)(setvar "Dimtxt" height)(setvar "cmdecho" 0)
               (setq el (entlast) ss2 (ssadd))
        (setq p2 (getpoint (setq p1 (mapcar (function (lambda (a b) (/ (+ a b) 2.))) (car data) (cadr data)))  
                              "\n Place annotation: "))
             (setvar 'nomutt 1)
        (command "leader" "_non" p1 "_non" p2 "" (last data) "" ^c)
        (setvar 'nomutt 0)
               (While (setq el (entnext el)) (ssadd el ss2))
               (setq bridge (entmakex (list (cons 0 "LINE") (cons 10 (car data)) (cons 11 (cadr data)))))
        (while (eq 5 (car (setq gr (grread T 15 0))))
                (redraw)
                  (setq p2 (vlax-curve-getClosestPointTo bridge (cadr gr)))
                    (repeat (setq n (sslength ss2))
                            (vla-move (vlax-ename->vla-object (ssname ss2 (setq ent (setq n (1- n)))))
                                  (vlax-3d-point p1)(vlax-3d-point p2))
                          )
                    
                         
                               (setq p1 p2)
                     )
               (entdel bridge)
                  )                                 
    )
 (*error* "")
     (princ)
     )

(defun c:demo (/ chfd data p1 p2 gr)
;;;Demo for pBe Jan 2014;;;
(if (not (tblsearch "LAYER" "dim"))
   (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (370 . 18) (2 . "dim") (70 . 0) (62 . 3) (6 . "Continuous")))
  
   (prompt "\nLayer : "dim" already exist - setting it to current and proceeding with routine...")
 )
(setvar 'clayer "dim")
(vl-load-com)        
(defun chfd (/ _dxf _para _valid a typ obj p1 p2 intrpt P3 P4)
(defun _dxf (e dx) (cdr (assoc dx (entget e))))
(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 p3 (_dxf obj 10) p4 (_dxf obj 11)))
          (progn
;;;         Kent Cooper                                                        ;;;
;;;        http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General        ;;;
;;;        /Find-segments-of-polyline/td-p/4785889                                    ;;;
            (defun ptpar (par)
              (reverse
                (cdr
                  (reverse (vlax-curve-getPointAtParam plent par)
                  )
                )
              )
            )
            (setvar "osmode" 0)
            (setq
              plent  (car a)        ; the PolyLine ENTity name
              verts  (cdr (assoc 90 (entget plent)))
                                ; number of VERTiceS
              prepar (fix (vlax-curve-getParamAtPoint
                            plent
                            (osnap (cadr a) "_nea")
                          )
                     )
                                ; PREceding-pick-point vertex's PARameter value
              p1     (ptpar (rem (1- (+ prepar verts)) verts))
              p4     (ptpar prepar)
              p3     (ptpar (rem (1+ prepar) verts))
              p2     (ptpar (rem (+ 2 prepar) verts))
            )                        ; setq
            (setq intrpt (inters p1 p4 p2 p3 nil))
          )
                      )(princ "\nNull/Invalid selection")
         
         )
     (list  P3 P4 
         (if intrpt
            (progn
                    (if (eq (rtos (distance p3 intrpt) 2 1) (rtos (distance p4 intrpt) 2 1))
                           (strcat "C"(rtos (distance p3 intrpt) 2 1))
                       (strcat 
                                  "C"
                                  (rtos (distance p3 intrpt) 2 1)
                                    "x"
                                  (rtos (distance p4 intrpt) 2 1)
                        
                        )
                    )
                 ) 
           "Invalid data"
             )
         )
)
(defun leader_final_point (p1 p2)
  (setq ty (getvar "TEXTSTYLE") kd3 0)
  (setq txt_long (* 1.3 (caadr (textbox (list '(0 . "text")(cons 1 (last data))(cons 40 height)(cons 41 0.7)(cons 7 ty))))))
  (if (< (car p1) (car p2))
       (setq p3 (polar p2 0 txt_long))
        (setq p3 (polar p2 (angtof "180") txt_long))
  )   
)
 
(setq tad (Getvar "dimtad") dtxt (getvar "Dimtxt")
     ech (getvar "cmdecho") gap (getvar "dimgap"))
(setq height 2.5)
        (if (setq judge (getreal "Input text height(Default 2.5)"))
             (setq height judge)                
        )
(if (eq (last (setq data (chfd))) "Invalid data")
           (princ "\nNo Data to process")
              (progn
               (setvar "dimtad" 0)(setvar "dimgap" -1)(setvar "Dimtxt" height)(setvar "cmdecho" 0)
               (setq el (entlast) ss2 (ssadd))
                        (princ (entget el))
        (setq p2 (getpoint (setq p1 (mapcar (function (lambda (a b) (/ (+ a b) 2.))) (car data) (cadr data)))  
                              "\n Place annotation: "))
                                                   
        (setq p3 (leader_final_point p1 p2) p_modify (list 0 height 0))
        
        (command "leader" "_non" p1 "_non" p2 p3 "" "" "n")
        (command "text" "j" "c" (mapcar '(lambda (a b c) (+ (/ (+ a b) 2.) (* c 0.2)))  p2 p3 p_modify)  height "" (last data) "")
        
               (While (setq el (entnext el)) (ssadd el ss2))
               (setq bridge (entmakex (list (cons 0 "LINE") (cons 10 (car data)) (cons 11 (cadr data)))))
        (while (eq 5 (car (setq gr (grread T 15 0))))
                (redraw)
                         (command "_move" ss2 "" "_non" p1 "_non" (setq p2 (vlax-curve-getClosestPointTo bridge (cadr gr))))
                               (setq p1 p2)
                     )
               (entdel bridge)
           )                                 
)
        (setvar "dimtad" tad) (setvar "dimgap" gap)(setvar "Dimtxt" dtxt)(setvar "cmdecho" ech)
)