Lisp help Selecting multi lines and labeling them

February 5, 2011

I have a lisp routine that labels lines with there lengths but i want to grab multiple lines and get it to label them with there lengths. Can any one help me?

(defun c:tl ()
(setq dscal (getvar "dimscale"))
(setq lspace (* 9.0 (/ dscal 96.0)))
(setq dimconv (/ 96.0 dscal))
(command "_.style" "jaytxt" "romans" "0" "0.80" "" "" "" "")
(command "regenauto" "OFF")
;----------set initial variables to nil-------------------------
(setq ent1 nil)
(setq pt1 nil)
(setq pt2 nil)
(setq xpt1 nil)
(setq ypt1 nil)
(setq xpt2 nil)
(setq ypt2 nil)
(setq pt1a nil)
(setq pt2a nil)
(setq tenl nil)
(setq tenl2 nil)
(setq tenf nil)
(setq tend nil)
(setq elo nil)
(setq aten nil)
(setq atenconv nil)
(setq txtjust nil)
(setq atenconvro nil)
(setq atenro nil)
(setq txtror nil)
(setq txtro nil)
(setq petxtd nil)
(setq ptltxtd nil)
(setq ptxt nil)
(setq petxt nil)
(setq ptltxt nil)
(setq txt nil)
;---------user input-----------------------------------------------------
(setvar "osmode" 0)  
(prompt "Pick joist line")
(while (= ent1 nil)
      (setq ent1 (entsel))
); end while
(setq ent1i ent1)
(setq ent_1 (entget (car ent1)))
(setq jspi (cdr (assoc 10 ent_1)))
(setq jepi (cdr (assoc 11 ent_1)))
(setq jspx (car jspi))
(setq jspy (cadr jspi))
(setq jsp2 (list jspx jspy))
(setq jepx (car jepi))
(setq jepy (cadr jepi))
(setq jep2 (list jepx jepy))

;(setq pt1 (getpoint "\n Pick point for LIVE end of tendon"))
; (setq xpt1 (car pt1))

; (setq ypt1 (cadr pt1))
; (setq pt1a (list xpt1 ypt1))
; (setvar "osmode" 161)
; (setq pt2 (getpoint pt1a "\n Pick point for OPPOSITE end of tendon"))
; (setvar "osmode" 1)
; (setq xpt2 (car pt2))
; (setq ypt2 (cadr pt2))
; (setq pt2a (list xpt2 ypt2))
(setq pt1a jsp2)
(setq pt2a jep2)
(setq aten (angle pt1a pt2a))
(setq mpt1 (/ (distance pt1a pt2a) 2.0))
(setq mpt (polar pt1a aten mpt1))
(setq tenl (+ (distance pt1a pt2a) 4.0))
(setq tenl2 (/ tenl 12.0))
(setq tenf (fix (+ tenl2 0.501)))
;--------ROUNDING UP FUNCTION-------------------
(if (> tenl2 tenf)
    (setq tend (+ tenf 1)))
(if (<= tenl2 tenf)
    (setq tend tenf))
(if (>= tend 9.0)
    (setq tenda (* (fix (+ (/ tend 2.0) 0.5)) 2.0))
    (setq tenda tend))
(setq tenda tenda)

;-------TEXT JUSTIFICATION----------------------------------------


(setq atenconv (* 180.0 (/ aten pi)))
(if (and (>= atenconv 0.0) (<= atenconv 90.1))
    (setq txtjust "mc"))
(if (and (> atenconv 90.1) (<= atenconv 270.1))
    (setq txtjust "mc"))
(if (> atenconv 270.1)
    (setq txtjust "mc"))
(setq atenro (- aten (/ pi 2.0)))

;--------TEXT POSITIONING----------------------------------------

(if (and (>= atenconv 0.0) (<= atenconv 90.1))
    (setq petxtd (- 0.0 lspace)))
(if (and (> atenconv 90.1) (<= atenconv 270.1))
    (setq petxtd lspace))
(if (>= atenconv 270.1)
    (setq petxtd (- 0.0 lspace)))
; (if (and (>= atenconv 0.0) (<= atenconv 90.0))
;     (setq ptltxtd (- 0.0 2.0)))
; (if (and (> atenconv 90.0) (<= atenconv 270.0))
;     (setq ptltxtd 2.0))
; (if (> atenconv 270.0)
;     (setq ptltxtd (- 0.0 2.0)))
; (setq ptxt (polar pt1a aten (- 0.0 16.0)))
(setq petxt (polar mpt atenro petxtd))
; (setq ptltxt (polar ptxt atenro ptltxtd))

(if (and (>= atenconv 0.0) (<= atenconv 90.1))
    (setq txtror aten))
(if (and (> atenconv 90.1) (<= atenconv 270.1))
    (setq txtror (- aten pi)))
(if (> atenconv 270.1)
    (setq txtror aten))
(setq txtro (* 180.0 (/ txtror pi)))


;-------TENDON LENGTH TEXT--------------------------------------

(setq txti (rtos tenda 2 0))
(setq txt (strcat txti "'"))

;-------TEXT PLACEMENT------------------------------------------

(setvar "osmode" 0)
(command "_.layer" "_m" "s-tech-jlen" "_c" "1" "" "")
(command "_.text" "_s" "jaytxt" "_j" txtjust petxt "6" txtro txt "")

;;;;----end of program-------------------------------------

) ;end defun

Edited May 8, 2012 by SLW210
Added Code Tags!!

February 6, 2011

Please post your existing code

February 6, 2011

there is the code up on the first post

February 6, 2011

I slightly modified your code

(defun c:lmark(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid)
 
 (vl-load-com)

 (defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
		  / oOsn cLay cTxt actSp nTxt
		  oDxf nDxf mPt xPt aDoc aSp lFlg)

 ; (Add_Masked_MText <Str> <Pt> <Hei> <Wid> <wiF> <Ang> <Mask>)
 
 (setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
		(vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
   ); end setq
   (if(= 1 aSp)
     (setq aSp(vla-get-ModelSpace aDoc))
     (setq aSp(vla-get-PaperSpace aDoc))
     ); end if
    (if(= :vlax-true(vla-get-Lock cLay))
   (progn
     (vla-put-Lock cLay :vlax-false)
     (setq lFlg T)
   ); end progn
); end if
    (if(= 1.0 wiF)
 (setq cTxt(strcat "\\pxqc;" Str))
 (setq cTxt(strcat "\\pxqc;{\\W" (rtos wiF) ";" Str "}"))
); end if
       (setq nTxt(vla-AddMText aSp
	    (vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
      nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
       ); end setq
 (entmod nDxf)
 (vla-getBoundingBox nTxt 'mPt 'xPt)
 (setq mPt(vlax-safearray->list mPt)
       xPt(vlax-safearray->list xPt)
       mPt(vlax-3d-point
	      (list(+(car mPt)(/(-(car xPt)(car mPt))2))
		 (+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
			 0.0))
		); end setq
         (vla-Move nTxt mPt(vlax-3D-point Pt))
  (if(and(> Ang 0)(<= Ang pi))
     (vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
     (vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
   ); end if
    (if lFlg
       (vla-put-Lock cLay :vlax-true)
     ); end if
  nTxt
 ); end of Add_Masked_MText

 (if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
 (setq oldSize lab:Size
lab:Size 
   (getreal 
     (strcat "\nText size <"(rtos lab:Size)">: ")))
 (if(null lab:Size)(setq lab:Size oldSize))
 (princ "\n<<< Select lines and curves to label >>> ")
 (if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
   (progn
     (setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object)))
     (vla-StartUndoMark aDoc)
     (foreach l(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam l)
	     ePar(vlax-curve-getEndParam l)
	     eLen(-(vlax-curve-getDistAtParam l ePar)
		      (vlax-curve-getDistAtParam l sPar))
             lPnt(vlax-curve-getPointAtDist l(/ eLen 2))
             iDr(vlax-curve-getFirstDeriv l
		  (vlax-curve-getParamAtPoint l lPnt))
	     iAng(- pi
		    (atan
		      (/(car iDr)
			(if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
             cTxt(strcat(rtos eLen 2 0)"'")
             tWid(caadr
		   (textbox
		      (list(cons 1 cTxt)
			 (cons 40 lab:Size)(cons 41 0.)))
	     ); end setq
(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng 1.0)
); end foreach
       (vla-EndUndoMark aDoc)
     ); end progn
   (princ "\n<!> Nothing selected <!> ")
   ); end if 
 (princ)
 ); end of c:lmark

Edited February 6, 2011 by Smirnoff
UNDO start and end marks was added

February 6, 2011

I made a routine to for the OP , but when I saw the codes that provided by Mr. Smirnoff , I felt shy to post them because

of the great routine that already given by him.

Great work Mr Smirnoff.

Appreciated.

February 6, 2011

... great routine that already given by him.

I think that you should not hesitate to submit your code to the forum. The more you write the code so the code will be better.

February 6, 2011

I think that you should not hesitate to submit your code to the forum. The more you write the code so the code will be better.

Thanks for the encouragement .

So comments are welcome anytime .

(defun c:Lentxt (/ ss)
 (if (setq ss (ssget "_:L" '((0 . "LINE"))))
   (
    (lambda (i / ss1 e dis pt1 pt2 pt3)
      (while
       (setq ss1 (ssname ss (setq i (1+ i))))
         (setq e (entget ss1 ))
      (setq dis (distance (setq pt1 (cdr (assoc 10 e)))(setq pt2 (cdr (assoc 11 e)))))
      (cond ((< (car pt1)(car pt2))
         (setq pt3 (polar pt1 (setq ang (angle pt1 pt2)) (/ dis 2.)))
         )
        ((> (car pt1)(car pt2))(setq pt3 (polar pt2 (setq ang (angle pt2 pt1)) (/ dis 2.)))
         )
      )
        (entmakex (list (cons 0 "TEXT")
              (cons 10 (polar pt3 ang 0))
                 (cons 1 (rtos dis 2))
               (cons 50 ang)
                     (cons 40 (getvar 'textsize))))  
        )
       )
    -1
   )
 (princ "\n No Line(s) selected")
 )
 (princ)
 )

Thanks.

Tharwat

Edited February 6, 2011 by Tharwat
Angular added to texts

February 7, 2011

Thank you both for the help.

Smirnoff

your code gave me this error

; error: no function definition: VLA-PUT-BACKGROUNDFILL

February 7, 2011

your code gave me this error
; error: no function definition: VLA-PUT-BACKGROUNDFILL

Please specify version and product name you use in your profile. It allow us to know what functions we can use for you what can't. Is your AutoCAD earlier than 2005 when background mask for text feature appear?

February 7, 2011

I just add ADJUSTMENTS section in my code. It allow more wide usage of this routine. Now you can adjust precision of measurement, suffix after measurement digits and use or don't use background mask for text. Now background mask is OFF.

(defun c:lmark(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid
       Precision Suffix BackMask)

[color="#0000ff"]  ; *****************************************************************************
 ;                                  ADJUSTMENTS                                ;
 ;                 (Modify it to adjust for your own requirements)              ;
 ; *****************************************************************************

 (setq Precision 0) 	; - precision of measurement (digits after decimal point)
 (setq Suffix "'")	; - Suffix after measirement for ex. "'" or "" for none  
 (setq BackMask nil)   ; - Background mask borders from 1.0 to 10.0             
 			;   or nil for none. Recomended value 1.0.              
 			;   !!! nil for versions ealer AutoCAD 2005 !!!          

  ; ******************************* END ADJUSTMENTS *****************************[/color]
 
 (vl-load-com)

 (defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
		  / oOsn cLay cTxt actSp nTxt
		  oDxf nDxf mPt xPt aDoc aSp lFlg)

 ; (Add_Masked_MText <Str> <Pt> <Hei> <Wid> <wiF> <Ang> <Mask>)
 
 (setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
		(vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
   ); end setq
   (if(= 1 aSp)
     (setq aSp(vla-get-ModelSpace aDoc))
     (setq aSp(vla-get-PaperSpace aDoc))
     ); end if
    (if(= :vlax-true(vla-get-Lock cLay))
   (progn
     (vla-put-Lock cLay :vlax-false)
     (setq lFlg T)
   ); end progn
); end if
    (if(= 1.0 wiF)
 (setq cTxt(strcat "\\pxqc;" Str))
 (setq cTxt(strcat "\\pxqc;{\\W" (rtos wiF) ";" Str "}"))
); end if
       (setq nTxt(vla-AddMText aSp
	    (vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
     (if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
      nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
       ); end setq
 (entmod nDxf)
 ); end progn
); end if
 (vla-getBoundingBox nTxt 'mPt 'xPt)
 (setq mPt(vlax-safearray->list mPt)
       xPt(vlax-safearray->list xPt)
       mPt(vlax-3d-point
	      (list(+(car mPt)(/(-(car xPt)(car mPt))2))
		 (+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
			 0.0))
		); end setq
         (vla-Move nTxt mPt(vlax-3D-point Pt))
  (if(and(> Ang 0)(<= Ang pi))
     (vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
     (vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
   ); end if
    (if lFlg
       (vla-put-Lock cLay :vlax-true)
     ); end if
  nTxt
 ); end of Add_Masked_MText

 (if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
 (setq oldSize lab:Size
lab:Size 
   (getreal 
     (strcat "\nText size <"(rtos lab:Size)">: ")))
 (if(null lab:Size)(setq lab:Size oldSize))
 (princ "\n<<< Select lines and curves to label >>> ")
 (if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
   (progn
     (setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object)))
     (vla-StartUndoMark aDoc)
     (foreach l(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam l)
	     ePar(vlax-curve-getEndParam l)
	     eLen(-(vlax-curve-getDistAtParam l ePar)
		      (vlax-curve-getDistAtParam l sPar))
             lPnt(vlax-curve-getPointAtDist l(/ eLen 2))
             iDr(vlax-curve-getFirstDeriv l
		  (vlax-curve-getParamAtPoint l lPnt))
	     iAng(- pi
		    (atan
		      (/(car iDr)
			(if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
             cTxt(strcat(rtos eLen 2 Precision)Suffix)
             tWid(caadr
		   (textbox
		      (list(cons 1 cTxt)
			 (cons 40 lab:Size)(cons 41 0.)))
	     ); end setq
(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng BackMask)
(vla-EndUndoMark aDoc)
); end foreach
     ); end progn
   (princ "\n<!> Nothing selected <!> ")
   ); end if 
 (princ)
 ); end of c:lmark

Have a nice day.

February 7, 2011

Layer and layer color to put labels added.

(defun c:lmark(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid lCol
         cLay nTxt Precision Suffix BackMask Layer Color)

[color="#800080"] ; *****************************************************************************
 ;                                  ADJUSTMENTS                                ;
 ;                 (Modify it to adjust for your own requirements)             ;
 ; *****************************************************************************

 (setq Precision 0) 		; - precision of measurement (digits after decimal point)
 
 (setq Suffix "")		; - Suffix after measirement for ex. "'" or "" for none
 
 (setq BackMask 1.0)   	; - Background mask borders from 1.0 to 10.0             
 				;   or nil for none. Reocomended value 1.0.              
 				;   !!! nil for versions ealer AutoCAD 2005 !!!
 
 (setq Layer "s-tech-jlen") 	; - layer of markers or nil for current layer
 
 (setq Color 1)		; - color of layer for ex. 1 (Red)

  ; ******************************* END ADJUSTMENTS *****************************[/color]
 
 (vl-load-com)

 (defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
		  / oOsn cLay cTxt actSp nTxt
		  oDxf nDxf mPt xPt aDoc aSp lFlg)

 ; (Add_Masked_MText <Str> <Pt> <Hei> <Wid> <wiF> <Ang> <Mask>)
 
 (setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
		(vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
   ); end setq
   (if(= 1 aSp)
     (setq aSp(vla-get-ModelSpace aDoc))
     (setq aSp(vla-get-PaperSpace aDoc))
     ); end if
    (if(= :vlax-true(vla-get-Lock cLay))
   (progn
     (vla-put-Lock cLay :vlax-false)
     (setq lFlg T)
   ); end progn
); end if
    (if(= 1.0 wiF)
 (setq cTxt(strcat "\\pxqc;" Str))
 (setq cTxt(strcat "\\pxqc;{\\W" (rtos wiF) ";" Str "}"))
); end if
       (setq nTxt(vla-AddMText aSp
	    (vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
     (if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
      nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
       ); end setq
 (entmod nDxf)
 ); end progn
); end if
 (vla-getBoundingBox nTxt 'mPt 'xPt)
 (setq mPt(vlax-safearray->list mPt)
       xPt(vlax-safearray->list xPt)
       mPt(vlax-3d-point
	      (list(+(car mPt)(/(-(car xPt)(car mPt))2))
		 (+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
			 0.0))
		); end setq
         (vla-Move nTxt mPt(vlax-3D-point Pt))
  (if(and(> Ang 0)(<= Ang pi))
     (vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
     (vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
   ); end if
    (if lFlg
       (vla-put-Lock cLay :vlax-true)
     ); end if
  nTxt
 ); end of Add_Masked_MText

 (if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
 (setq oldSize lab:Size
lab:Size 
   (getreal 
     (strcat "\nText size <"(rtos lab:Size)">: ")))
 (if(null lab:Size)(setq lab:Size oldSize))
 (princ "\n<<< Select lines and curves to label >>> ")
 (if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
   (progn
     (setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
    lCol(vla-get-Layers aDoc)
    ); end setq
     (vla-StartUndoMark aDoc)
     (if Layer
(if(vl-catch-all-error-p
     (vl-catch-all-apply
       'vla-Item(list lCol Layer)))
    (progn
      (setq cLay(vla-Add lCol Layer))
      (vla-put-Color cLay Color) 
      ); end progn
  ); end if
); end if
     (foreach l(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam l)
	     ePar(vlax-curve-getEndParam l)
	     eLen(-(vlax-curve-getDistAtParam l ePar)
		      (vlax-curve-getDistAtParam l sPar))
             lPnt(vlax-curve-getPointAtDist l(/ eLen 2))
             iDr(vlax-curve-getFirstDeriv l
		  (vlax-curve-getParamAtPoint l lPnt))
	     iAng(- pi
		    (atan
		      (/(car iDr)
			(if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
             cTxt(strcat(rtos eLen 2 Precision)Suffix)
             tWid(caadr
		   (textbox
		      (list(cons 1 cTxt)
			 (cons 40 lab:Size)(cons 41 0.)))
	     ); end setq
(setq nTxt(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng BackMask))
(if Layer
   (vla-put-Layer nTxt Layer)
  ); end if
(vla-EndUndoMark aDoc)
); end foreach
     ); end progn
   (princ "\n<!> Nothing selected <!> ")
   ); end if 
 (princ)
 ); end of c:lmark

Edited February 7, 2011 by Smirnoff
grammar mistake

February 7, 2011

Thank you. I knew it was my 2002 version. I was going to try it at work on 2011. Thanks again for the help. And next time i will give all the info when asking for help.

May 4, 2012

Hello I am new to the site and fairly new to lisp. I loaded and ran the above lisp posted by Smirnoff. When I select a line that is 70" it labels it as ";70

The lisp is clearly working but I need some help with the formatting. Also I was wondering if it is possible to label the line by rounding to the nearest foot? That is to say if I selected the same line that is 70" it would simply label it with a 6

Thanks for you help.

JB

May 4, 2012

Not sure about how to round imperic, try this out

(defun c:lmark(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid lCol
         cLay nTxt Precision Suffix BackMask Layer Color)
 ; *****************************************************************************
 ;                                  ADJUSTMENTS                                ;
 ;                 (Modify it to adjust for your own requirements)             ;
 ; *****************************************************************************
 (setq Precision 0)   ; - precision of measurement (digits after decimal point)

 (setq Suffix "")  ; - Suffix after measirement for ex. "'" or "" for none

 (setq BackMask 1.0)    ; - Background mask borders from 1.0 to 10.0             
     ;   or nil for none. Reocomended value 1.0.              
     ;   !!! nil for versions ealer AutoCAD 2005 !!!

 (setq Layer "s-tech-jlen")  ; - layer of markers or nil for current layer

 (setq Color 1)  ; - color of layer for ex. 1 (Red)
  ; ******************************* END ADJUSTMENTS *****************************

 (vl-load-com)
 ;; by Ian Bryant
(defun round (num)
                               (if (minusp num)
                               (* 2 (fix (- (/ num 2.0) 0.5)))
                               (* 2 (fix (+ (/ num 2.0) 0.5)))
                               )
                               )
 (defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
    / oOsn cLay cTxt actSp nTxt
    oDxf nDxf mPt xPt aDoc aSp lFlg)
 ; (Add_Masked_MText <Str> <Pt> <Hei> <Wid> <wiF> <Ang> <Mask>)

 (setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
  (vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
   ); end setq
   (if(= 1 aSp)
     (setq aSp(vla-get-ModelSpace aDoc))
     (setq aSp(vla-get-PaperSpace aDoc))
     ); end if
    (if(= :vlax-true(vla-get-Lock cLay))
   (progn
     (vla-put-Lock cLay :vlax-false)
     (setq lFlg T)
   ); end progn
); end if
    (if(= 1.0 wiF)
 (setq cTxt(strcat "[url="file://\\pxqc"]\\pxqc[/url];" Str))
 (setq cTxt(strcat "[url="file://\\pxqc{\\W"]\\pxqc{\\W[/url]" (rtos wiF) ";" Str "}"))
); end if
       (setq nTxt(vla-AddMText aSp
     (vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
     (if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
      nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
       ); end setq
 (entmod nDxf)
 ); end progn
); end if
 (vla-getBoundingBox nTxt 'mPt 'xPt)
 (setq mPt(vlax-safearray->list mPt)
       xPt(vlax-safearray->list xPt)
       mPt(vlax-3d-point
       (list(+(car mPt)(/(-(car xPt)(car mPt))2))
   (+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
    0.0))
  ); end setq
         (vla-Move nTxt mPt(vlax-3D-point Pt))
  (if(and(> Ang 0)(<= Ang pi))
     (vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
     (vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
   ); end if
    (if lFlg
       (vla-put-Lock cLay :vlax-true)
     ); end if
  nTxt
 ); end of Add_Masked_MText
 (if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
 (setq oldSize lab:Size
lab:Size 
   (getreal 
     (strcat "\nText size <"(rtos lab:Size)">: ")))
 (if(null lab:Size)(setq lab:Size oldSize))
 (princ "\n<<< Select lines and curves to label >>> ")
 (if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
   (progn
     (setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
    lCol(vla-get-Layers aDoc)
    ); end setq
     (vla-StartUndoMark aDoc)
     (if Layer
(if(vl-catch-all-error-p
     (vl-catch-all-apply
       'vla-Item(list lCol Layer)))
    (progn
      (setq cLay(vla-Add lCol Layer))
      (vla-put-Color cLay Color) 
      ); end progn
  ); end if
); end if
     (foreach curve(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam curve)
      ePar(vlax-curve-getEndParam curve)
      eLen(-(vlax-curve-getDistAtParam curve ePar)
        (vlax-curve-getDistAtParam curve sPar))
             lPnt(vlax-curve-getPointAtDist curve(/ eLen 2))
             iDr(vlax-curve-getFirstDeriv curve
    (vlax-curve-getParamAtPoint curve lPnt))
      iAng(- pi
      (atan
        (/(car iDr)
   (if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
             ;;cTxt(strcat(rtos eLen 2 Precision)Suffix)
             ;; cTxt(strcat(rtos eLen 4 0);|Suffix|;;******************************
            cTxt(rtos (round eLen) 4 0)
             tWid(caadr
     (textbox
        (list(cons 1 cTxt)
    (cons 40 lab:Size)(cons 41 0.)))
      ); end setq
(setq nTxt(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng BackMask))
(if Layer
   (vla-put-Layer nTxt Layer)
  ); end if
(vla-EndUndoMark aDoc)
); end foreach
     ); end progn
   (princ "\n<!> Nothing selected <!> ")
   ); end if
 (princ)
 ); end of c:lmark

~'J'~

May 4, 2012

Fixo, first off I would like to thank you for your assistance. Your knowledge and willingness to lend a hand is much appreciated.

I downloaded your revised lisp, it seems that it is now labeling the lines in feet and inches. The 70" line is now labeled as 5'-10"

Any chance this could follow the logic of Smirnoff's previous lisp where it reported in a decimal form and then the user could choose how many digits after decimal were reported but in feet instead of inches?

I was just thinking that since Smirnoff's lisp could label a line that was 5-1/2" as 6 (5.5 but rounded to 6 when the precision was set to 0) that maybe it could be modified to do the same thing with feet so it could label the 70" line as 5.83 and then round to 6 with a precision of 0.

Thanks again.

JB

May 4, 2012

I will finish this part of feet rounding, but been busy right know

See you later, sorry

~'J'~

May 4, 2012

How about this code?

(defun c:lmark(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid lCol
         cLay nTxt Precision Suffix BackMask Layer Color)
 ; *****************************************************************************
 ;                                  ADJUSTMENTS                                ;
 ;                 (Modify it to adjust for your own requirements)             ;
 ; *****************************************************************************
 (setq Precision 0)   ; - precision of measurement (digits after decimal point)

 (setq Suffix "")  ; - Suffix after measirement for ex. "'" or "" for none

 (setq BackMask 1.0)    ; - Background mask borders from 1.0 to 10.0             
     ;   or nil for none. Reocomended value 1.0.              
     ;   !!! nil for versions ealer AutoCAD 2005 !!!

 (setq Layer "s-tech-jlen")  ; - layer of markers or nil for current layer

 (setq Color 1)  ; - color of layer for ex. 1 (Red)
  ; ******************************* END ADJUSTMENTS *****************************

 (vl-load-com)
 ;; by Ian Bryant
(defun round (num)
                               (if (minusp num)
                               (* 2 (fix (- (/ num 2.0) 0.5)))
                               (* 2 (fix (+ (/ num 2.0) 0.5)))
                               )
                               )
 (defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
    / oOsn cLay cTxt actSp nTxt
    oDxf nDxf mPt xPt aDoc aSp lFlg)
 ; (Add_Masked_MText <Str> <Pt> <Hei> <Wid> <wiF> <Ang> <Mask>)

 (setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
  (vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
   ); end setq
   (if(= 1 aSp)
     (setq aSp(vla-get-ModelSpace aDoc))
     (setq aSp(vla-get-PaperSpace aDoc))
     ); end if
    (if(= :vlax-true(vla-get-Lock cLay))
   (progn
     (vla-put-Lock cLay :vlax-false)
     (setq lFlg T)
   ); end progn
); end if
    (if(= 1.0 wiF)
 (setq cTxt(strcat "[url="file://\\pxqc"]\\pxqc[/url];" Str))
 (setq cTxt(strcat "[url="file://\\pxqc{\\W"]\\pxqc{\\W[/url]" (rtos wiF) ";" Str "}"))
); end if
       (setq nTxt(vla-AddMText aSp
     (vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
     (if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
      nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
       ); end setq
 (entmod nDxf)
 ); end progn
); end if
 (vla-getBoundingBox nTxt 'mPt 'xPt)
 (setq mPt(vlax-safearray->list mPt)
       xPt(vlax-safearray->list xPt)
       mPt(vlax-3d-point
       (list(+(car mPt)(/(-(car xPt)(car mPt))2))
   (+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
    0.0))
  ); end setq
         (vla-Move nTxt mPt(vlax-3D-point Pt))
  (if(and(> Ang 0)(<= Ang pi))
     (vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
     (vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
   ); end if
    (if lFlg
       (vla-put-Lock cLay :vlax-true)
     ); end if
  nTxt
 ); end of Add_Masked_MText
 (if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
 (setq oldSize lab:Size
lab:Size 
   (getreal 
     (strcat "\nText size <"(rtos lab:Size)">: ")))
 (if(null lab:Size)(setq lab:Size oldSize))
 (princ "\n<<< Select lines and curves to label >>> ")
 (if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
   (progn
     (setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
    lCol(vla-get-Layers aDoc)
    ); end setq
     (vla-StartUndoMark aDoc)
     (if Layer
(if(vl-catch-all-error-p
     (vl-catch-all-apply
       'vla-Item(list lCol Layer)))
    (progn
      (setq cLay(vla-Add lCol Layer))
      (vla-put-Color cLay Color) 
      ); end progn
  ); end if
); end if
     (foreach curve(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam curve)
      ePar(vlax-curve-getEndParam curve)
      eLen(-(vlax-curve-getDistAtParam curve ePar)
        (vlax-curve-getDistAtParam curve sPar))
             lPnt(vlax-curve-getPointAtDist curve(/ eLen 2))
             iDr(vlax-curve-getFirstDeriv curve
    (vlax-curve-getParamAtPoint curve lPnt))
      iAng(- pi
      (atan
        (/(car iDr)
   (if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
             ;;cTxt(strcat(rtos eLen 2 Precision)Suffix)
             ;; cTxt(strcat(rtos eLen 4 0);|Suffix|;;******************************
            cTxt (rtos (cvunit (round eLen) "in" "inch")2 0)
             tWid(caadr
     (textbox
        (list(cons 1 cTxt)
    (cons 40 lab:Size)(cons 41 0.)))
      ); end setq
(setq nTxt(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 1.0 iAng BackMask))
(if Layer
   (vla-put-Layer nTxt Layer)
  ); end if
(vla-EndUndoMark aDoc)
); end foreach
     ); end progn
   (princ "\n<!> Nothing selected <!> ")
   ); end if
 (princ)
 ); end of

May 7, 2012

Fixo, thank you for the timely response. I will test this tomorrow when I have access to CAD, and let you know.

Thanks,

JB

May 7, 2012

Good day Fixo,

I tested your provided code, it was labeling in inches. So I made one small change to it.

I changed:

cTxt (rtos (cvunit (round eLen) "in" "inch")2 0)

To:

cTxt (rtos (cvunit (round eLen) "in" "feet")2 0)

It is now labeling the lines in feet. I was not clear in my previously request, but I was hoping to have it always round up to the next foot instead of the nearest foot. Do you know how to make it round up so 14'-0" = 14, but 14'-1" = 15? Sorry for not communicating this previously.

Thanks

JB

May 7, 2012

Hi , JB

I will look at this later,

~'J'~

Lisp help Selecting multi lines and labeling them

Recommended Posts

j_spawn_h

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Tharwat

fixo

Posted Images

BIGAL

Link to comment

Share on other sites

j_spawn_h

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Tharwat

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Tharwat

Link to comment

Share on other sites

j_spawn_h

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

Smirnoff

Link to comment

Share on other sites

j_spawn_h

Link to comment

Share on other sites

JBlom

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

JBlom

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

JBlom

Link to comment

Share on other sites

JBlom

Link to comment

Share on other sites

fixo

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity