[编程交流] 将多段线长度提取到

(defun c:Len2Fld ( / *error* tables doc spc p s q ExitFlag ) 
(vl-load-com)
     (while
 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 (setq tables (LM:ss->vla (ssget "_X" '((0 . "ACAD_TABLE")))))
 (LM:ActiveSpace 'doc 'spc)   
 (cond
   (
     (setq p
       (LM:Selectif
         (lambda ( x )
           (vlax-property-available-p
             (vlax-ename->vla-object x) 'Length
           )
         )
         "\nMétré longeur, Selectionner cable: " nil
       )
     )
     (setq s
       (strcat "%<\\AcObjProp Object(%<\\_ObjId "
         (LM:GetObjectID doc (vlax-ename->vla-object p)) ">%).Length \\f "%lu6">%"
       )
     )         
     (while
       (progn
         (or ExitFlag
           (progn
             (initget "Point")
             (setq p (nentsel "\nSelect Text, MText or Attribute for Result [Point] <Exit> : "))
           )
         )
        
         (cond
           (
             ExitFlag nil
           )
           (
             (vl-consp p)
           
             (if (wcmatch (cdr (assoc 0 (entget (car p)))) "ATTRIB,*TEXT")
               (vla-put-TextString (vlax-ename->vla-object (car p)) s)
               (princ "\n** Object Must be Text, MText or Attribute **")
             )
           )
         )
       )
     )
   )
 )
 (vla-regen doc AcActiveViewport)
 (princ)
)
)  
(defun LM:ActiveSpace ( *doc *spc )
 (set *spc
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (set *doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true (vla-get-MSpace (eval *doc)))
     )
     (vla-get-ModelSpace (eval *doc))
     (vla-get-PaperSpace (eval *doc))
   )
 )
)
(defun LM:Selectif ( foo str nest / e )
   (while
   (progn
     (setq e (car ((if nest nentsel entsel) str)))
     
     (cond
       (
         (eq 'ENAME (type e))
         (if (not (foo e)) (princ "\n** Invalid Object Selected **"))
       )
     )
   )
 )
 e
)
(defun LM:GetObjectID ( doc obj )
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
   (itoa (vla-get-Objectid obj))
 )
)
(defun LM:ss->vla ( ss )
  (if ss
   (
     (lambda ( i / e l )
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq l (cons (vlax-ename->vla-object e) l))
       )
       l
     )
     -1
   )
 )
)

(vl-load-com)
(defun c:demo (/ attlst blk doc en_pt obj ss ss1 ss2 st_pt)
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           st_pt (vlax-curve-getStartPoint obj)
           en_pt (vlax-curve-getEndPoint obj)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "RJ45CAT6") (66 . 1))
               )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "RJ45CAT6") (66 . 1))
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LENGTH")
             (vla-put-TextString
               a
               (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:GetObjectID doc obj)
                       ">%).Length \\f "%lu6">%"
               )
             )
           )
         )
       )
     )
   )
 )
 (vla-regen doc AcActiveViewport)
 (princ)
)
(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)

(vl-load-com)
(defun c:demo (/ attlst blk doc en_pt obj ss ss1 ss2 st_pt)
 (command "_.ucs" "_world")
 (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (setq obj   (vlax-ename->vla-object (ssname ss (setq i (1- i))))
           st_pt (vlax-curve-getStartPoint obj)
           en_pt (vlax-curve-getEndPoint obj)
     )
     (command "_.zoom" "_C" st_pt "")
     (setq ss1 (ssget "_C"
                      (polar st_pt (* 0.25 pi) 0.1)
                      (polar st_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "etiquetteVDI") (66 . 1))
               )
     )
     (command "_.zoom" "_C" en_pt "")
     (setq ss2 (ssget "_C"
                      (polar en_pt (* 0.25 pi) 0.1)
                      (polar en_pt (* 1.25 pi) 0.1)
                      '((0 . "INSERT") (2 . "etiquetteVDI") (66 . 1))
               )
     )
     (cond (ss1
            (setq blk (vlax-ename->vla-object (ssname ss1 0)))
           )
           (ss2
            (setq blk (vlax-ename->vla-object (ssname ss2 0)))
           )
     )
     (if blk
       (progn
         (setq attlst (vlax-invoke blk 'GetAttributes))
         (foreach a attlst
           (if (= (vla-get-TagString a) "LONGUEUR")
             (vla-put-TextString
               a
               (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:GetObjectID doc obj)
                       ">%).Length \\f "%lu6">%"
               )
             )
           )
         )
       )
     )
   )
 )
 (command "UCS" "P")
 (vla-regen doc AcActiveViewport)
 (princ)
)
(defun LM:GetObjectID (doc obj)
 (if (eq "X64" (strcase (getenv "PROCESSOR_ARCHITECTURE")))
   (vlax-invoke-method
     (vla-get-Utility doc)
     'GetObjectIdString
     obj
     :vlax-false
   )
   (itoa (vla-get-Objectid obj))
 )
)