[编程交流] 未对齐非线性长度

;------------------------------------------------ LenghtOfObject ------------------------
(defun LenghtOfObject (obj / len)
 (if (vl-catch-all-error-p (setq len (vl-catch-all-apply 'vlax-curve-getDistAtParam
   (list obj (vl-catch-all-apply 'vlax-curve-getEndParam (list obj)))))) nil len
 )
)
;------------------------------------------------ c:LengthText ------------------------
(defun c:LengthText ( / *ModelSpace* sel)
 (vl-load-com)
 (setq *ModelSpace* (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-acad-object))))
 (setvar "errno" 0) ; when the user on ssget press Enter the errno is set to 52
 (while (and (setq sel (ssget))(/= (getvar "errno") 52))
   (if sel
     (progn
       (mapcar (function (lambda (ent / obj olg stpt TxtObj next_pt)
         (setq  Obj (vlax-ename->vla-object ent))
         (if (setq olg (LenghtOfObject obj))
           (progn
             (setq stpt (vlax-curve-getStartPoint obj))
             (setq TxtObj (vla-addText *ModelSpace* (rtos olg 2 2) (vlax-3d-point stpt) (getvar"textsize"))) ;_ end of vla-addText
             (setq next_pt (if (= "AcDbArc" (vlax-get obj 'ObjectName))
               (vlax-curve-getendpoint obj); end point
               (vlax-curve-getPointAtParam obj (1+ (fix (vlax-curve-getParamAtPoint obj stpt))))
             ))
             (vla-put-Rotation TxtObj (angle stpt next_pt))
             (setq stpt (vla-get-InsertionPoint TxtObj))
             (vla-put-alignment TxtObj acAlignmentBottomLeft)
             (vla-put-TextAlignmentPoint TxtObj stpt)
           )
           (if (ssmemb ent sel)(ssdel ent sel))
         )
       ))(vl-remove-if-not '(lambda(x)(= (type x) 'ENAME)) (mapcar 'cadr (ssnamex sel))))
     )
   )
 )
 (princ)
)
;------------------------------------------------ c:LenghtText1 ------------------------
(defun c:LengthText1 ( / *ModelSpace* sel Obj )
 (vl-load-com)
 (setq *ModelSpace* (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-acad-object))))
 (setvar "errno" 0) ; when the user on ssget press Enter the errno is set to 52
 (while (and (setq sel (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC"))))(/= (getvar "errno") 52))
   (if sel
     (progn
       (mapcar (function (lambda (ent / obj oname stpt TxtObj next_pt)
         (setq  Obj (vlax-ename->vla-object ent))
         (if (LenghtOfObject obj)
           (progn
             (setq oname (vlax-get obj 'ObjectName))
             (setq stpt (vlax-curve-getStartPoint obj))
             (setq TxtObj (vla-addText *ModelSpace* (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string (vla-get-ObjectID obj))">%)."(if (= "AcDbArc" oname) "Arc" "")"Length \\f "%lu2%pr2%ps[, mm]">%")
                (vlax-3d-point stpt) (getvar"textsize"))
             ) ;_ end of vla-addText
             (setq next_pt (if (= "AcDbArc" oname)
               (vlax-curve-getendpoint obj); end point
               (vlax-curve-getPointAtParam obj (1+ (fix (vlax-curve-getParamAtPoint obj stpt))))
             ))
             (vla-put-Rotation TxtObj (angle stpt next_pt))
             (setq stpt (vla-get-InsertionPoint TxtObj))
             (vla-put-alignment TxtObj acAlignmentBottomLeft)
             (vla-put-TextAlignmentPoint TxtObj stpt)
           )
           (if (ssmemb ent sel)(ssdel ent sel))
         )
       ))(vl-remove-if-not '(lambda(x)(= (type x) 'ENAME)) (mapcar 'cadr (ssnamex sel))))
     )
   )
 )
 (princ)
)

(defun vlax-curve-getMidPoint (obj / len)
 (vlax-curve-getPointAtDist
   obj
   (* 0.5
      (vlax-get obj
         (if (vlax-property-available-p obj (setq len "length"))
           len
           (strcat "arc" len)
           ) ;_ end of if
         ) ;_ end of vlax-get
      ) ;_ end of *
   ) ;_ end of vlax-curve-getPointAtDist
 ) ;_ end of defun

...
...
[color="#696969"]  (setq oname (vlax-get obj 'ObjectName))
             (setq stpt ([color="red"]vlax-curve-getStartPoint[/color] obj))
             (setq TxtObj (vla-addText *ModelSpace* (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string (vla-get-ObjectID obj))">%)."(if (= "AcDbArc" oname) "Arc" "")"Length \\f "%lu2%pr2%ps[, mm]">%")[/color]
...
...

...
(setq stpt ([color="red"]vlax-curve-getMidPoint[/color] obj))
...

...
...
(if (setq olg (LenghtOfObject obj))
           (progn
              (setq stpt ([color="red"]vlax-curve-getStartPoint[/color] obj)) ;<---- this
             (setq TxtObj
...
...

;associative dimension "line" 
(defun [color="red"][b]ldim[/b][/color] (lin / p1 p2 mp sz)
;hanhphuc 14/10/2014
 (mapcar 'set '(p1 p2) (mapcar ''((e) (cdr (assoc e (entget lin)))) '(10 11)))
 (setq sz (* 0.05 (distance p1 p2)) mp (mapcar '(lambda (a b) (* 0.5 (+ a b))) p1 p2))
 (vl-cmdf "_dimaligned" p1 p2 mp)
 ('((obj)
    (mapcar
     '(lambda (a b) (vlax-put obj a b))
     '("Arrowhead1Type"         "Arrowhead2Type"          "extensionlineextend"           "extensionlineoffset"
"TextHeight"                 "TextInside"                  "VerticalTextPosition"   "TextGap"
)
     (list 19 19 0. 0. sz :vlax-true 1 sz)
     )
    (vlax-put-property obj 'TextFill :vlax-true)
    )
   (vlax-ename->vla-object (entlast))
   )
 ) ;_ end of defun

(defun c:test (/ var l ss)
 (setq        l   '("CMDECHO" "OSMODE" "DIMTIH" "DIMTOH" "DIMASSOC")
var (mapcar 'getvar l)
) ;_ end of setq
(mapcar 'setvar l '(0 0 0 0 2))
 (command "_UNDO" "be")
 (if (setq ss (ssget ":L" '((0 . "LINE"))))
   (mapcar '[b][color="red"]ldim[/color][/b] (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   ) ;_ end of if
 (command "_UNDO" "e")
 (vl-cmdf "_erase" ss "")
 (mapcar 'setvar l var)
 (princ)
 ) ;_ end of defun