Jump to content
bobbykimchi

LL - Label Line changing code to Label point with its own layer name

Recommended Posts

bobbykimchi

Hi,

I am trying to find a way to label points with its own layer name like the attached lisp commando. It does it with line/polylines.

 

Also I am trying to find a way to do this with multiple points, therefore the rotation of the imported mtext does not need to be aligned. 

Could anyone help me find a way to edit the code downstairs or help me with a new code? 

 

(defun alg-ang    (obj pnt)
  (angle '(0. 0. 0.)
     (vlax-curve-getfirstderiv
       obj
       (vlax-curve-getparamatpoint
         obj
         pnt
         )
       )
     )
  )

(defun C:LL (/ *error* acsp adoc ang fld midp mtx rot sset txtpt)
  (defun *error*  (msg)
    (if
      (vl-position
    msg
    '("console break"
      "Function cancelled"
      "quit / exit abort"
      )
    )
       (princ "Error!")
       (princ msg)
       )
       (vla-endundomark      
(vla-get-activedocument
           (vlax-get-acad-object)
           )
)
    (princ)
    )

  (or adoc
      (setq adoc
         (vla-get-activedocument
           (vlax-get-acad-object)
           )
        )
      )
  (if (and
    (= (getvar "tilemode") 0)
    (= (getvar "cvport") 1)
    )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
    )
  (vla-startundomark      
adoc
)
(if (setq sset (ssget "_:L" (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))
  (foreach obj
    (mapcar 'vlax-ename->vla-object
      (vl-remove-if 'listp
        (mapcar 'cadr (ssnamex sset))))
 (if (not (eq "AcDbArc"  (vla-get-objectname obj)))  
(setq midp (vlax-curve-getclosestpointto obj
         (vlax-curve-getpointatparam obj
   ( / (- (vlax-curve-getEndParam obj)
      (vlax-curve-getStartParam obj)) 2))
      )
      )
   (setq midp (vlax-curve-getclosestpointto obj
        (vlax-curve-getpointatdist obj
   ( / (vla-get-arclength obj) 2)))
         )
   )


(setq ang (alg-ang obj midp))
    
(if (> pi ang (/ pi 2))
        (setq ang (+ ang pi))
  )
(if (> (* pi 1.5) ang pi)
  (setq ang (+ ang pi))
  )
      (setq rot (+ ang (/ pi 2)))

    (setq txtpt (polar midp rot
               (if (zerop (getvar "dimtxt"))
             0.1
             (/ (getvar "dimtxt") 2)))
      )

(setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId "
              (itoa (vla-get-objectid obj))
              ">%).Layer>%")

)

       (setq mtx (vlax-invoke
             acsp 'AddMText midp 0.0 fld)
           )
     (vlax-put mtx 'AttachmentPoint
           8
           
           )
    (vlax-put mtx 'InsertionPoint
           txtpt
           )
         (vlax-put mtx 'Rotation
           ang
           )
    )
  )
(princ)
)
(princ "\n\t\t\tType LL to label curves with layer name\t")
(prin1)

(vl-load-com)

ll-Label A line with its own layer name.txt

Share this post


Link to post
Share on other sites
Emmanuel Delay

Like this?

 

Command LL

 



(defun M-Text (pt str ht)
 (entmakex (list (cons 0 "MTEXT")         
                 (cons 100 "AcDbEntity")
                 (cons 100 "AcDbMText")
                 (cons 10 pt)
                 (cons 40 ht)
                 (cons 1 str)))
 )

(defun c:ll ( / points i point layer ip ht)
  (setq ht 2.5)                                          ;; Text height.  Feel free to pick your desired height
  (princ "\nSelect points: ")
  (setq points (ssget (list (cons 0 "POINT"))))
  (setq i 0)
  (repeat (sslength points)
    (setq layer (cdr (assoc 8 (entget (ssname points i)))))
    (setq ip (cdr (assoc 10 (entget (ssname points i)))))
    (M-Text ip layer ht)
    (setq i (+ i 1))
  )  
  (princ)
)

 

Or maybe you want the Mtext in the layer of the point?  (Or any other extras?)

  • Thanks 1

Share this post


Link to post
Share on other sites
rlx

oh darn Emmanuel beat me to it, awell , at least (unlike me) he probably knows what he was doing :P

 

lol....oh , that's the command , because don't want to redefine my own LL command (load lisp)

 


(defun alg-ang (obj pnt)
  (angle '(0. 0. 0.) (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj pnt))))

(defun C:LoL (/ *error* acsp adoc ang fld midp mtx rot sset txtpt)
  (defun *error* (msg)
    (if (vl-position msg '("console break" "Function cancelled" "quit / exit abort"))
      (princ "Error!") (princ msg)) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    (princ)
  )
  (or adoc (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
  (if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1))
    (setq acsp (vla-get-paperspace adoc)) (setq acsp (vla-get-modelspace adoc)))
  (vla-startundomark adoc)
  (if (setq sset (ssget "_:L" (list (cons 0 "point"))))
    (foreach obj
      (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex sset))))
      ;(if (not (eq "AcDbArc" (vla-get-objectname obj)))
      ;  (setq midp (vlax-curve-getclosestpointto obj (vlax-curve-getpointatparam obj
      ;    (/ (- (vlax-curve-getEndParam obj)(vlax-curve-getStartParam obj)) 2))))
      ;  (setq midp (vlax-curve-getclosestpointto obj (vlax-curve-getpointatdist obj
      ;    (/ (vla-get-arclength obj) 2)))))
      ;(setq ang (alg-ang obj midp))
      (setq ang 0 midp (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))
      (if (> pi ang (/ pi 2)) (setq ang (+ ang pi)))
      (if (> (* pi 1.5) ang pi) (setq ang (+ ang pi)))
      (setq rot (+ ang (/ pi 2)))
      (setq txtpt (polar midp (* pi 0.25) (if (zerop (getvar "dimtxt")) 2.5 (getvar "dimtxt"))))
      (setq fld (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid obj)) ">%).Layer>%"))
      (setq mtx (vlax-invoke acsp 'AddMText midp 0.0 fld))
      (vlax-put mtx 'AttachmentPoint  (vlax-put mtx 'InsertionPoint txtpt) (vlax-put mtx 'Rotation ang)
    )
  )
  (princ)
)
(princ "\n\t\t\tType LoL to label curves with layer name\t")
(prin1)

(vl-load-com)

 

time (almost) to enjoy the weekend :beer:

 

gr. R.

  • Like 1
  • Thanks 1

Share this post


Link to post
Share on other sites
bobbykimchi

Thanks @Emmanuel Delay. Would be good to get it in the same layer if possible. 🤩

Share this post


Link to post
Share on other sites
Emmanuel Delay

Sure

 



(defun M-Text (pt str ht lay)
 (entmakex (list (cons 0 "MTEXT")         
                 (cons 100 "AcDbEntity")
                 (cons 100 "AcDbMText")
                 (cons 10 pt)
                 (cons 40 ht)
                 (cons 8 lay)
                 (cons 1 str)))
 )

(defun c:ll ( / points i point layer ip ht)
  (setq ht 2.5)                                          ;; Text height.  Feel free to pick your desired height
  (princ "\nSelect points: ")
  (setq points (ssget (list (cons 0 "POINT"))))
  (setq i 0)
  (repeat (sslength points)
    (setq layer (cdr (assoc 8 (entget (ssname points i)))))
    (setq ip (cdr (assoc 10 (entget (ssname points i)))))
    (M-Text ip layer ht layer)
    (setq i (+ i 1))
  )  
  (princ)
)

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...