Mleader with block and attributes

[BIGAL]

I just tested again with your sample dwg, by copying code from here and it worked, maybe try setting LISPSYS to 1, then load code. I am using Bricscad V25.

 

Did you try it on your sample dwg ? If your picking a "Leader" object that is a different type of object to a "Mleader".

[AlexS]

Thanks Bigal,

 

I just went in and lispsys is already set to 1.

 

 

[GLAVCVS]

The problem here is that the block is not referenced correctly. This can be checked with vla-get-contentType, which returns 1 instead of 2.

I've spent a little time trying to rehabilitate your friend's code.

I haven't tested it thoroughly but it should work

 

 

; 19/03/10   ALEX SARRIS / Wayne Joslin.
'			Updated:  12-Jan-2012.   WSJ  -  to include  MultiLine-Attributes.
; This Program Updates the Length & Grade Tags  on a Notation Block -   based on a Picked-Pipe.
; By reading the USIL & DSIL  attributes in this notation block.
; Program also creates 3D line in specific Layers - based on the USIL & DSIL  - for 12D use.
; 
;
;	This function IS case-dependent.
;	Use function in the following manner:		(if (/= (WJfindStr PipeLyrNam "GGG") 0)  (then))
; 10/02/2025 REHABILITADO POR GLAVCVS
(defun WJfindStr (inStrg srchStrg / ff aa ll ss)
	(setq ff 0 aa 1 ll (strlen instrg))
	(setq sll (strlen srchStrg))
	(setq ll (+ (- ll sll) 1))
	(while (<= aa ll) (progn
		(setq ss (substr inStrg aa sll))
		(if (= ss srchStrg) (setq ff aa))		; found substring at location (ff)
		(setq aa (1+ aa))
	))
	(setq aa ff)	; Returns (ff)    0 = Not found.
)
(defun HowManyDecplacesSTRG (argstrg / aaa exideciplaces decilocn leng instrg)	; Copied this func from Pad3D.  It seems ACAD2011 is not doing (rtos ?? 2 1) properly anymore.
;	Returns the Number of Decimal places in the given number STRING.
	(setq exideciplaces 0)
	(setq decilocn 0)
	(setq instrg (rtos (atof argstrg)))		; ensure the string is a number first.  ie. Conv to float & back to strg.
	(setq leng (strlen instrg))
	(setq aaa 1)
	(while (<= aaa leng)
		(setq substrg (substr instrg aaa 1))
		(if (and (= decilocn 0) (= substrg ".")) (setq decilocn aaa))	; if not found yet, but have found 1st deciplace...
		(setq aaa (+ aaa 1))
	)
	(if (> decilocn 0) (setq exideciplaces (- leng decilocn)))		; how many deciplaces are there.
	(setq exideciplaces exideciplaces)					; Rturns Number of dec-Places.
)
(defun Min2decplacesSTRG (argstrg minReqd / aaa bbb instrg)	; Copied this func from Pad3D.  It seems ACAD2011 is not doing (rtos ?? 2 1) properly anymore.
;	Pad end of given string with 0S  -  IF minimum of given Decimal Places is not existing.
	(setq instrg (rtos (atof argstrg)))		; ensure the string is a number first.  ie. Conv to float & back to strg.
	(setq aaa (HowManyDecplacesSTRG instrg))	; aaa = Number of DeciPlaces in the existing string.
	(if (< aaa minReqd) (progn			; Min required.   If equal or over,  keep String as it is.
		(if (= aaa 0) (setq instrg (strcat instrg ".")))	; if NO deciplaces at all,  must put in the Deci-Point.
		(setq bbb (- minReqd aaa))		; Number of extra  0s required.
		(while (> bbb 0)			; pad 0s to end of string.
			(setq instrg (strcat instrg "0"))
			(setq bbb (- bbb 1))
		)
	))
	(setq instrg instrg)			; returns new string
)
;--------------------------------------



(defun C:PIPE3D ()
  (setvar "cmdecho" 0)
  (prompt "\n** Creates 3D-Lines from  picked Line-Entity.")
  (prompt "\n** Updates Pipe-Length & Grade Attribs in Notation Block.")
  (setq cclayer (getvar "CLAYER"))	; current Layer

  (COMMAND ".COLOR" "BYLAYER")
  (COMMAND ".LINETYPE" "S" "BYLAYER" "")



  (setq xxx 9.9)		; just to keep the loop busy
  (while (/= xxx -999.9) (progn
    (setq insxx 0.0 insyy 0.0)				; In-case the Picked-Line is nested within a Block/Xref.
    (setq en (entsel "\nPick U/S end of Pipe  (ie. Line Entity) ")) ; returns nil  if nothing picked   (nentsel allows picking of Nested objects
    (setq ed1 (cdr en))
    (setq ppt (car ed1))				; Picked-point.
      	(setq pptxx (car ppt))				; X,Y  coords of Pick-Point
      	(setq pptyy (car (cdr ppt)))
    (setq en (car en))
    (setq ent (entget en))				; Main Entity data.


    (if (= (cdr (assoc 0 ent)) "INSERT") (progn		; If main Entity is a Block/Xref -   (similar to Ncopy)  ie. Sub-entity.
 		(setq insrtpt (cdr (assoc 10 ent)))	; get its Insertion Point.
      		(setq insxx (car insrtpt))		; The nested Entities are stored as Local Co-ords within the Block.
      		(setq insyy (car (cdr insrtpt)))	; So to obtain World Coords - we must add nexted coords to Insertion Pt.

	    	(setq en (nentselp "." ppt))		; Using the Original Picked-Pt,  select the nested Entity.
    		(setq en (car en))
    		(setq ent (entget en))			; Sub Entity data.
    ))
    (setq PipeLyrNam (strcase (cdr (assoc 8 ent))))	; The Pipe's Layername. to Uppercase.
    (princ "\n    Picked-Line. (Layername) = ") (princ PipeLyrNam) (princ "\n")


    (if (= (cdr (assoc 0 ent)) "LINE") (progn		; The selected Entity - Must be a LINE  object.

	(setq lyrnam3D "")				; The Line should be on a known Layer - to identify it.
	(if (/= (WJfindStr PipeLyrNam "DRAIN") 0) (setq lyrnam3D "DRAIN-3D"))
	(if (/= (WJfindStr PipeLyrNam "SEWER") 0) (setq lyrnam3D "SEWER-3D"))
	(if (/= (WJfindStr PipeLyrNam "-DRN") 0) (setq lyrnam3D "DRAIN-3D"))
	(if (/= (WJfindStr PipeLyrNam "-SEW") 0) (setq lyrnam3D "SEWER-3D"))
	(if (= lyrnam3D "") (progn			; But, if the Layername is NO help,  ask user what type of Line this is.
		(initget 1 "S D")			; Bit 1 - prevents user from just entering Enter.
		(setq ptype (strcase (getkword "\n    Enter Pipe Type:   (S)ewer (D)rainage : ")))	; to Uppercase
		(if (= ptype "S") (setq lyrnam3D "SEWER-3D") (setq lyrnam3D "DRAIN-3D"))
	))
	(if (= lyrnam3D "SEWER-3D") (setq lyrcolr "MAGENTA") (setq lyrcolr "114"))	; Color:  Sewer/Drain,  Magenta,Green.
	(setq en (tblsearch "LAYER" lyrnam3D))
	(if (= en nil)		; The Layer did NOT exist.  - so create it.
      (COMMAND ".LAYER" "N" lyrnam3D "C" lyrcolr lyrnam3D "U" lyrnam3D "T" lyrnam3D "ON" lyrnam3D "")
      (COMMAND ".LAYER" "U" lyrnam3D "T" lyrnam3D "ON" lyrnam3D "")		; else, Layer already exists, ensure Unlocked.
    )
	(princ (strcat "\n    3D-Lines will be placed in Layer:   " lyrnam3D "\n"))


 	(setq strtpt (cdr (assoc 10 ent)))		; get start pt.
 	(setq endpt (cdr (assoc 11 ent)))		; get end pt.

        (setq v1 (distance strtpt ppt))			; pickPt to start.Pt.  Which is closer
        (setq v2 (distance endpt ppt))			; pickPt to end.Pt.  Which is closer
	(if (< v2 v1) (progn
		(setq SwapPt strtpt)			; Pick Pt was closer to end pt of Line - so swap ends.
		(setq strtpt endpt)			; (ie. Want StrtPt as the U/S end  -  being the 1st Pt.)
		(setq endpt SwapPt)
	))



							; Set Pipe to World Coordinates - in case its was nested within Block.
      	(setq strtxx (+ insxx (car strtpt)))
      	(setq strtyy (+ insyy (car (cdr strtpt))))
	(setq strtpt (list strtxx strtyy 0.0))		; re-create its start Pt - by adding the Block/Xref Insert Pt.
      	(setq endxx (+ insxx (car endpt)))
      	(setq endyy (+ insyy (car (cdr endpt))))
	(setq endpt (list endxx endyy 0.0))		; re-create its end Pt - by adding the Block/Xref Insert Pt.
        ;;;(setq PipeLeng (WSJlength strtxx strtyy endxx endyy))	; Overall Pipe Length.  (2D.)     Dont use Distance, as Line maybe 3D.
        (setq PipeLeng (distance (list strtxx strtyy) (list endxx endyy)))	; recreates a 2D-LINE to get its Length.
	(setq StrgLeng (rtos PipeLeng 2 1))		; Apparently, Acad2011  is not doing this properly anymore. - Hence my func on next line.
	(setq StrgLeng (Min2decplacesSTRG strgleng 1))	; return with min of 1 deci.place.
;(princ)
;(princ "strgleng = ")
;(princ strgleng)
;(princ)


		; Using Original Pick-Point of Line - Use a Crossing-select to find all Lines in a specific Layer  & Delete them.
	(setq pt1 (list (- pptxx 0.9) (- pptyy 0.9)))
	(setq pt2 (list (+ pptxx 0.9) (+ pptyy 0.9)))
	(if (setq ssv (ssget "_C" pt1 pt2))			; Find all entities on a specific Layer.
 	  (progn						; If we have a list - then step thru each Entity
        	(setq cc 0)					; internal counter.  Foreach Block
        	(setq numents (sslength ssv))			; how many Blocks in Dwg.
        	(while (< cc numents)
              		(setq en (ssname ssv cc))			; Primary entity name
              		(setq ed (entget en))
              		(setq laynam (strcase (cdr (assoc 8 ed)))) ; Layername - uppercase
			(if (= laynam lyrnam3D) (progn
				(princ (strcat "\n  -Delete existing entity in  " lyrnam3D " ..."))
				(entdel en)
			))
              		(setq cc (+ cc 1))
   	))	)





	(setq usil -999.9) (setq dsil -999.9)
        (setq enpik (entsel "\nPick the Block containing U/S,D/S Inverts."))	; returns nil  if nothing picked.  (cddr (vl-remove-if-not (function (lambda (x) (OR (= (car x) 330) (= (car x) 302)))) LSTENT))
        (setq enx (car enpik))			; Skip thru all the Attribs  to obtain the USIL & DSIL.
        (setq entx (entget enx))
	
;;;        (setq enx (entnext enx))		; Attribute is next sub-entity.
;;;        (setq entx (entget enx))
	
	(if (setq opc1 (= (cdr (assoc 0 (entget enx))) "INSERT"))
	  (setq enx (entnext enx)		; Attribute is next sub-entity.
		entx (entget enx)
		opc2 nil
	  )
	  (if (setq opc2 (= (cdr (assoc 0 (entget enx))) "MULTILEADER"))
;;;	    (SETQ entx (ENTGET (CDR (ASSOC 330 (MEMBER (ASSOC 304 (SETQ LSTENT (ENTGET enx))) LSTENT)))))           (SETQ entx (ENTGET (CDR (ASSOC 330 (MEMBER (ASSOC 304 (SETQ LSTENT (ENTGET (CAR (ENTSEL))))) LSTENT)))))  (entget (cdr (car (CDR (vl-remove-if-not (function (lambda (x) (= (car x) 330))) LSTENT)))))  (ASSOC 101 LSTENT)
	    (setq entx (entget (cdr (car (setq lst1 (cddr (vl-remove-if-not (function (lambda (x) (member (car x) '(330 302)))) (entget enx)))))))
		  lst lst1
	    )
	  )
	)
	    
        (while (and entx (member (strcase (cdr (assoc 0 entx))) '("ATTRIB" "ATTDEF")))
                (if (= (strcase (cdr (assoc 2 entx))) "USIL")
		  (progn
		    (setq usil (atof (cdr (assoc 302 lst))));(atof (cdr (assoc 1 entx))))
		    (setq membr (member (assoc 101 entx) entx))
					; find MultiLine-Attrib.  ie. sub-list (member) dxf 101 onwards.
		    (if	membr
		      (setq usil (atof (cdr (assoc 1 membr))))
		    )			; if so - use the sub-list attrib value.
					;(princ "    got membr101 = ") (princ (rtos usil))
		  )
		)
                (if (= (strcase (cdr (assoc 2 entx))) "DSIL")
		  (progn
		    (setq dsil (atof (cdr (assoc 302 lst))));(atof (cdr (assoc 1 entx))))
		    (setq membr (member (assoc 101 entx) entx))
					; find MultiLine-Attrib.  ie. sub-list (member) dxf 101 onwards.
		    (if	membr
		      (setq dsil (atof (cdr (assoc 1 membr))))
		    )			; if so - use the sub-list attrib value.
		  )
		)
	  (if opc1
	    (setq enx  (entnext enx)
		  entx (entget enx)
	    )
	    (if lst
	      (if (setq lst (cddr lst))
	        (setq entx (entget (cdr (car lst))))
		(setq entx nil)
	      )
	      (setq entx nil)
	    )
	  )
        )


	(if (= usil dsil)					; calculate new grade of Pipe - allow rounding & convert to String.
		(setq newgrade 0.0)
		(setq newgrade (+ (/ PipeLeng (abs (- usil dsil))) 0.045))		; allows for rounding
	)
	(if (> newgrade 50.0) (setq strggrade (rtos newgrade 2 0)) (setq strggrade (rtos newgrade 2 1)))



				; Re-skip thru the Notation Block - to update length & Grade.
        (setq enx (car enpik) lst lst1)
        (setq entx (entget enx))
	(if opc1
          (setq	enx  (entnext enx)	; Attribute is next sub-entity.
		entx (entget enx)
	  )
	  (if lst
	    (setq entxATT (entget (cdr (car lst)));lista del atributo; entxATT (entget (cdr (car lst)))
		  lst  (cddr lst)
	    )
	    (setq entx nil)
	  )
	)
        (while (AND
		 entx
		 (OR
		   (= (strcase (cdr (assoc 0 entx))) "ATTRIB")
		   (= (strcase (cdr (assoc 0 entxATT))) "ATTDEF")
		 )
	       )
	  (if (= (strcase (cdr (assoc 0 entx))) "ATTRIB")
	    (progn
	      (setq campo (strcase (cdr (assoc 2 entx))))
	      (cond
		((wcmatch campo "LENG,LENGTH")
		 (setq entx (subst (cons 1 (strcat StrgLeng "")) (assoc 1 (cdr (member (assoc 1 entx) entx))) entx))	; MultiLine-Attrib. Substitute new value into old position.
		 (setq entx (subst (cons 1 (strcat StrgLeng "")) (assoc 1 entx) entx))			; Normal-Text-Attrib.   - Just do both anyway.
		 (entmod entx)
	        )
		((wcmatch campo "GR,GRDE,GRADE")
		 (setq entx (subst (cons 1 strggrade) (assoc 1 (cdr (member (assoc 1 entx) entx))) entx))	; MultiLine-Attrib. Substitute new value into old position.
		 (setq entx (subst (cons 1 strggrade) (assoc 1 entx) entx))			; Normal-Text-Attrib.   - Just do both anyway.
		 (entmod entx)
		)
              )
	    )
	    (if (= (strcase (cdr (assoc 0 entxATT))) "ATTDEF")
	      (progn
		(setq entx (entget enx) campo (cdr (assoc 2 entxATT)))
		(cond
		  ((wcmatch campo "LENG,LENGTH")
		   (setq entx (subst (cons 302 (strcat StrgLeng "")) asoc302 entx))	; MultiLine-Attrib. Substitute new value into old position.
;;;		   (setq entx (subst (cons 1 (strcat StrgLeng "")) (assoc 1 entx) entx))			; Normal-Text-Attrib.   - Just do both anyway.
		   (entmod entx)
	          )
		  ((wcmatch campo "GR,GRDE,GRADE")
		   (setq entx (subst (cons 302 strggrade) asoc302 entx))	; MultiLine-Attrib. Substitute new value into old position.
;;;		   (setq entx (subst (cons 1 strggrade) (assoc 1 entx) entx))			; Normal-Text-Attrib.   - Just do both anyway.
		   (entmod entx)
		  )
		  (T
		   (princ "\nCaso no esperado")
		  )
                )
	      )
	    )
	  )
;;;                (setq enx (entnext enx))
;;;                (setq entx (entget enx))
	  (if opc1
	    (setq enx  (entnext enx)
		  entx (entget enx)
	    )
	    (if lst
	      (setq entxATT (entget (cdr (car lst)))
		    asoc302 (cadr lst)
		    lst (cddr lst)
	      )
	      (setq entx nil)
	    )
	  )
        )


                   (if (< usil -999.0)
                       (princ "\n**WARNING**:  U/S-IL  Was Not found."))
                   (if (< dsil -999.0)
                       (princ "\n**WARNING**:  D/S-IL  was Not found."))
                   (if (> dsil usil)
                       (princ "\n**WARNING**:  U/S-IL  specified is  Lower than  D/S-IL"))

      	(setq xx (car strtpt))
      	(setq yy (car (cdr strtpt)))
	(setq pt1 (list xx yy usil))
      	(setq xx (car endpt))
      	(setq yy (car (cdr endpt)))
	(setq pt2 (list xx yy dsil))
        (setvar "CLAYER" lyrnam3D)
	(command ".LINE" "none" pt1 "none" pt2 "")
        (setvar "CLAYER" cclayer)
	(princ "\n    Next - Pipe...")
    )
    (princ "\n  **Object selected was NOT a Line.")	; else
    )
  ))	; end while
(princ)
)
(princ "\n\tc:PIPE3D loaded. Start command with PIPE3D.")

 

[GLAVCVS]

I had to change or override the lines of code that use 'command' to make it compatible with my version of AutoCAD.

 

I think I left it as it was.

Just in case, don't destroy your old code.

[AlexS]

Hello GLAVCVS,

 

I just ran it and it works perfectly.

 

You are my HERO

Now i don't need to be exploding the mleader and more which makes it tough for editing.

 

Really... Really... Really appreciate it.

[AlexS]

Hello Glavcvs,

 

This lisp SILDIL is part of the same group but a lot shorter.
Would this work with the SILDIL block in Mleader the same ? or need changes

 

Regards Alex
 

SILDIL.LSP SAMPLE.dwg

[GLAVCVS]

It depends on the attributes
If they have the same name and are implemented in the same way, it should work.
I'll take a look this afternoon when I get home

[AlexS]

Thanks Glavcvs,

 

Really appreciate it.