[编程交流] 新圆弧尺寸程序

;DIMMARC.LSP - Dimension an arc with length, rather than angle
;(c) 1998 Tee Square Graphics
(defun C:DIMARC (/ arc ent obj l)
 (setq cmd (getvar "cmdecho")
       arc (entsel "\nPick ARC to dimension: ")
       ent (entget (car arc))
       obj (cdr (assoc 0 ent)))
 (if (= obj "ARC")
   (progn
     (setvar "cmdecho" 1)
     (setq l (* (cdr (assoc 40 ent))
                (if (minusp (setq l (- (cdr (assoc 51 ent))
                                       (cdr (assoc 50 ent)))))
                  (+ pi pi l) l)))
     (command "_.dimangular" arc "_t" (rtos l))
     (while (= (logand (getvar "cmdactive") 1) 1)
       (command pause))
     (setvar "cmdecho" cmd))
   (alert "Object selected is not an ARC."))
 (princ)
)

(defun c:ArcDim (/ *error* AT:CycleThroughSS p1 ent p2 ss d1 d2)
 ;; label Arc with Dimension between two picked points
 ;; Alan J. Thompson, 11.14.11
 (vl-load-com)
 (defun *error* (msg)
   (and ent (redraw ent 4))
   (and *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (princ (strcat "\nError: " msg))
   )
 )
 (defun AT:CycleThroughSS (ss / l i e)
   ;; Cycle through a selection set to choose one
   ;; ss - selection set
   ;; Alan J. Thompson, 03.30.11
   (if (eq (type ss) 'PICKSET)
     (if (eq (setq l (sslength ss)) 1)
       (ssname ss 0)
       (progn (princ "\n<Tab> to cycle through entities: ")
              (redraw (setq e (ssname ss (setq i 0))) 3)
              (while (eq (cadr (grread nil 10)) 9)
                (mapcar 'redraw (list e (setq e (ssname ss (setq i (rem (1+ i) l))))) '(4 3))
              )
              (redraw e 4)
              e
       )
     )
   )
 )
 (vla-startundomark
   (cond (*AcadDoc*)
         ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   )
 )
 (cond ((not vla-addDimArc) (alert "AutoCAD version not supported!"))
       ((not (setq p1 (getpoint "\nSpecify fist point on arc: "))))
       ((not (setq ent (AT:CycleThroughSS (ssget "_C" p1 p1 '((0 . "ARC"))))))
        (alert "Point must be on arc!")
       )
       ((redraw ent 3))
       ((not (setq p2 (getpoint p1 "\nSpecify other point on arc: "))))
       ((not (and (setq ss (ssget "_C" p2 p2 '((0 . "ARC"))))
                  (vl-some '(lambda (e) (equal ent (cadr e))) (ssnamex ss))
             )
        )
        (alert "Point must be on arc!")
       )
       ((vlax-invoke
          (vlax-get *AcadDoc*
                    (if (eq (getvar 'CVPORT) 1)
                      'Paperspace
                      'Modelspace
                    )
          )
          'addDimArc
          (cdr (assoc 10 (entget ent)))
          (trans p1 1 0)
          (trans p2 1 0)
          (vlax-curve-getPointAtDist
            ent
            (+ (min (setq d1 (vlax-curve-getDistAtPoint ent (trans p1 1 ent)))
                    (setq d2 (vlax-curve-getDistAtPoint ent (trans p2 1 ent)))
               )
               (/ (abs (- d1 d2)) 2.)
            )
          )
        )
       )
 )
 (*error* nil)
 (princ)
)

Command: _dimarc
Select arc or polyline arc segment:
Specify arc length dimension location, or [Mtext/Text/Angle/[color=red]Partial[/color]]:

(defun c:ArcDim (/ *error* AT:CycleThroughSS cmd p1 ent p2 ss d1 d2)
 ;; label Arc with Dimension between two picked points
 ;; Alan J. Thompson, 11.14.11
 (vl-load-com)
 (defun *error* (msg)
   (and ent (redraw ent 4))
   (and cmd (setvar 'CMDECHO cmd))
   (and *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (princ (strcat "\nError: " msg))
   )
 )
 (defun AT:CycleThroughSS (ss / l i e)
   ;; Cycle through a selection set to choose one
   ;; ss - selection set
   ;; Alan J. Thompson, 03.30.11
   (if (eq (type ss) 'PICKSET)
     (if (eq (setq l (sslength ss)) 1)
       (ssname ss 0)
       (progn (princ "\n<Tab> to cycle through entities: ")
              (redraw (setq e (ssname ss (setq i 0))) 3)
              (while (eq (cadr (grread nil 10)) 9)
                (mapcar 'redraw (list e (setq e (ssname ss (setq i (rem (1+ i) l))))) '(4 3))
              )
              (redraw e 4)
              e
       )
     )
   )
 )
 (vla-startundomark
   (cond (*AcadDoc*)
         ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   )
 )
 (setq cmd (getvar 'CMDECHO))
 (setvar 'CMDECHO 0)
 (cond ((not vla-addDimArc) (alert "AutoCAD version not supported!"))
       ((not (setq p1 (getpoint "\nSpecify fist point on arc: "))))
       ((not (setq ent (AT:CycleThroughSS (ssget "_C" p1 p1 '((0 . "ARC"))))))
        (alert "Point must be on arc!")
       )
       ((redraw ent 3))
       ((not (setq p2 (getpoint p1 "\nSpecify other point on arc: "))))
       ((not (and (setq ss (ssget "_C" p2 p2 '((0 . "ARC"))))
                  (vl-some '(lambda (e) (equal ent (cadr e))) (ssnamex ss))
             )
        )
        (alert "Point must be on arc!")
       )
       ((vl-cmdf "_.dimarc" (list ent p1) "_partial" "_non" p1 "_non" p2 PAUSE))
;;;        ((vlax-invoke
;;;           (vlax-get *AcadDoc*
;;;                     (if (eq (getvar 'CVPORT) 1)
;;;                       'Paperspace
;;;                       'Modelspace
;;;                     )
;;;           )
;;;           'addDimArc
;;;           (cdr (assoc 10 (entget ent)))
;;;           (trans p1 1 0)
;;;           (trans p2 1 0)
;;;           (vlax-curve-getPointAtDist
;;;             ent
;;;             (+ (min (setq d1 (vlax-curve-getDistAtPoint ent (trans p1 1 ent)))
;;;                     (setq d2 (vlax-curve-getDistAtPoint ent (trans p2 1 ent)))
;;;                )
;;;                (/ (abs (- d1 d2)) 2.)
;;;             )
;;;           )
;;;         )
;;;        )
 )
 (*error* nil)
 (princ)
)

(defun c:ArcDim (/ *error* AT:CycleThroughSS cmd p1 ent p2 ss d1 d2)
 ;; label Arc with Dimension between two picked points
 ;; Alan J. Thompson, 11.14.11
 (vl-load-com)
 (defun *error* (msg)
   (and ent (redraw ent 4))
;;;    (and cmd (setvar 'CMDECHO cmd))
   (and *AcadDoc* (vla-endundomark *AcadDoc*))
   (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
     (princ (strcat "\nError: " msg))
   )
 )
 (defun AT:CycleThroughSS (ss / l i e)
   ;; Cycle through a selection set to choose one
   ;; ss - selection set
   ;; Alan J. Thompson, 03.30.11
   (if (eq (type ss) 'PICKSET)
     (if (eq (setq l (sslength ss)) 1)
       (ssname ss 0)
       (progn (princ "\n<Tab> to cycle through entities: ")
              (redraw (setq e (ssname ss (setq i 0))) 3)
              (while (eq (cadr (grread nil 10)) 9)
                (mapcar 'redraw (list e (setq e (ssname ss (setq i (rem (1+ i) l))))) '(4 3))
              )
              (redraw e 4)
              e
       )
     )
   )
 )
 (vla-startundomark
   (cond (*AcadDoc*)
         ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   )
 )
;;;  (setq cmd (getvar 'CMDECHO))
;;;  (setvar 'CMDECHO 0)
 (cond ((not vla-addDimArc) (alert "AutoCAD version not supported!"))
       ((not (setq p1 (getpoint "\nSpecify fist point on arc: "))))
       ((not (setq ent (AT:CycleThroughSS (ssget "_C" p1 p1 '((0 . "ARC,CIRCLE"))))))
        (alert "Point must be on arc!")
       )
       ((redraw ent 3))
       ((not (setq p2 (getpoint p1 "\nSpecify other point on arc: "))))
       ((not (and (setq ss (ssget "_C" p2 p2 '((0 . "ARC,CIRCLE"))))
                  (vl-some '(lambda (e) (equal ent (cadr e))) (ssnamex ss))
             )
        )
        (alert "Point must be on arc!")
       )
;;;        ((vl-cmdf "_.dimarc" (list ent p1) "_partial" "_non" p1 "_non" p2 PAUSE))
       ((vlax-invoke
          (vlax-get *AcadDoc*
                    (if (eq (getvar 'CVPORT) 1)
                      'Paperspace
                      'Modelspace
                    )
          )
          'addDimArc
          (cdr (assoc 10 (entget ent)))
          (trans p1 1 0)
          (trans p2 1 0)
          (vlax-curve-getClosestPointTo
            ent
            (mapcar '(lambda (a b) (/ (+ a b) 2.)) (trans p1 1 ent) (trans p2 1 ent))
          )
;;;           (vlax-curve-getPointAtDist
;;;             ent
;;;             (+ (min (setq d1 (vlax-curve-getDistAtPoint ent (trans p1 1 ent)))
;;;                     (setq d2 (vlax-curve-getDistAtPoint ent (trans p2 1 ent)))
;;;                )
;;;                (/ (abs (- d1 d2)) 2.)
;;;             )
;;;           )
        )
       )
 )
 (*error* nil)
 (princ)
)