Message 1 of 5
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello all,
I'm trying to find a solution that can prevent the multileader text from drastically shifting or at least relocate the multileader back at its original location using autolisp or visual lisp. It appears I have successfully reset the points using (SUBST (CONS 10/12 ...)(ASSOC 10/12 ...)edata) and (ENTMOD); however, that either restores the leaders that existed prior to running my program or has no effect on the shifted text. I've included the code (commented out) that did the point substitutions.
***** EDIT *****
I apologize, I finally realized that I had used the DOS_STRTOKENS function in my code. I just needed a unique string for a group name to help me keep what was exploded as a unit of sorts. For DOS_STRTOKENS to work, you would need to get and load DOSLIB from Robert McNeil & Associates. (It's free and well worth having if you don't have it already). I've replaced it with a simpler and much better line of code.
***** End EDIT *****
Here's my (edited) code which does all that I want except that the text gets drastically shifted:
****** UPDATE 11-3-21 (1) ******
P.S. I have a different experience in some drawings vs. others now.
Now, in some drawings the multileader text position does NOT get shifted drastically while it still does in other drawings.
I am currently trying to identify the differences between these drawings...
****** UPDATE 11-3-21 (2) ******
The finished, working, non-text-shifting code is updated below... Thanks @john.uhden for the UCS suggestion! That solved my text-shifting problem! (had to (TRANS (x y z) 1 0) the points since the UCS is set to VIEW now while they are added to the MULTILEADER)
I've used two of my library subroutines in my code: PTTXT.LSP; and GROUPS.LSP. These files are not necessary for the commands C:AREANOTE/C:AN to work. PTTXT is to visualize points for debugging and design. GROUPS has a function for deleting empty groups and this routine leaves two of them with each iteration... so I delete them each time it is run. I've attached these files in case anyone wants them.
****** UPDATE 11-4-21 ******
I ran into some errors. The updated code below now works without error ... for me. I left my debugging code in place because that's my practice. It won't do anything at all unless you set the debug-* symbols to T.
;;; Edited: 11-4-2021
;;;
;;;****************************************************************************
(DEFUN areanote_error (msg / )
(setvar "cmdecho" 1)
(setvar "pickstyle" old-pickstyle)
(setvar "osmode" old-osmode)
(if old-ucslist
(cond
((eq (caddr old-ucslist) 1)
(command ".ucs" "W"))
((eq (cadr old-ucslist) 1)
(command ".ucs" "V"))
((not (eq (car old-ucslist) ""))
(command ".ucs" "NA" "R" (car old-ucslist)))
)
)
(COMMAND ".UNDO" "END")
(PRINC "\nAREANOTE ERROR: ")
(PRINC msg)
(setq *error* NIL)
(princ)
)
;;;****************************************************************************
(DEFUN C:AREANOTE ( / old-ucslist mldr-ss ml-edata landing-pt ultext-pt ml-text ml-grp-name mt-grp-name exml-ss mlcnt item-ename ml-txtbox txt-ins txt-txt txt-line-cnt ldrcnt this-mltobj lmldr-1 lmldr-2 lmldr-3 rmldr-0 rmldr-1 rmldr-2 rmldr-3)
(VL-LOAD-COM)
(COMMAND ".UNDO" "BEGIN")
(IF debug-cmd
(PROGN
(PRINC "\nAfter .UNDO BEGIN command ")
(PRINC)
)
)
(IF C:DEMGroups NIL (LOAD "groups" "\nFile GROUPS.LSP not loaded! "))
(IF C:DEMGroups (C:DEMGroups)); Deletes empty groups... and we made a couple of them!
(setq old-cmdecho (getvar "cmdecho")) ; save the current state of the system variables to be set
(setq old-pickstyle (getvar "pickstyle")) ; ditto
(setq old-osmode (getvar "osmode")) ; ditto
(setq old-ucslist (LIST (GETVAR "UCSNAME")(GETVAR "UCSVP")(GETVAR "WORLDUCS")))
(setq olderror *error*)
(IF areanote_error (SETQ *error* areanote_error)) ; apply this program's error function
(*push-error-using-command*)
(setvar "cmdecho" 0)
(setvar "pickstyle" 1)
(setvar "osmode" 0)
(command ".ucs" "v")
(SETQ mldr-ss (SSGET ":S+." '((0 . "MULTILEADER")))) ; force the selection to a single MULTILEADER
(IF (AND mldr-ss (SETQ this-mltobj (VLAX-ENAME->VLA-OBJECT (SSNAME mldr-ss 0)))); verify the object exists
(PROGN
(setq ml-edata (ENTGET (SSNAME mldr-ss 0))
ml-text (CDR (ASSOC 1 ml-edata))
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore .explode command (1) ")
(PRINC)
)
)
(SETQ ml-copy (vlax-vla-object->ename (setq ml-copy-obj (vla-copy this-mltobj))))
(command ".explode" ml-copy); copy the multileader and explode it
(IF debug-cmd
(PROGN
(PRINC "\nAfter .explode command (1) ")
(PRINC)
)
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore (SSGET \"P\") (1) ")
(PRINC)
)
)
(SETQ exml-ss1 NIL) ; NIL out any old selection set of this name
(SETQ exml-ss1 (SSGET "P")); create a new selection set of the group
(IF debug-cmd
(PROGN
(ALERT (STRCAT "exml-ss1 SSLENGTH = " (ITOA (SSLENGTH exml-ss1))))
(PRINC "\nAfter (SSGET \"P\") (1) ")
(PRINC)
)
)
(SETQ mlcnt 0
item-ename NIL
)
(IF debug-cmd
(ALERT (STRCAT "BEFORE WHILE: exml-ss1 SSLENGTH = "
(ITOA (SSLENGTH exml-ss1))
)
)
)
(SETQ item-ename (SSNAME exml-ss1 mlcnt))
(WHILE (< mlcnt (SSLENGTH exml-ss1))
(IF (AND item-ename
(VLAX-ENAME->VLA-OBJECT item-ename)
(VLAX-PROPERTY-AVAILABLE-P (VLAX-ENAME->VLA-OBJECT item-ename) 'ObjectName)
(IF (errortrap '(ENTGET item-ename))
(EQ (CDR (ASSOC 0 (ENTGET item-ename)))"MTEXT")
)
)
(IF (EQ (CDR (ASSOC 0 (ENTGET item-ename))) "MTEXT")
(PROGN
(IF debug-cmd
(PROGN
(PRINC "\nBefore .explode command (2) ")
(PRINC)
)
)
(setq ticnt 0)
(command ".explode" item-ename)
(IF debug-unk
(PROGN
(PRINC "\nExplode (1) ")
(PRINC)
)
)
(SETQ exml-ss2 NIL) ; NIL out any old selection set of this name
(SETQ exml-ss2 (SSGET "P")); make a selection set of the group
(IF debug-cmd
(PROGN
(COND
((NOT exml-ss2)
(ALERT "THERE IS NOT exml-ss2!"))
((AND exml-ss2 (<(SSLENGTH exml-ss2)1))
(ALERT "SS IS EMPTY!"))
(exml-ss2
(ALERT (STRCAT "exml-ss2 HAS "
(ITOA (SSLENGTH exml-ss2))
" ITEMS!"
"\nItem 1 is "
(CDR (ASSOC 0 (ENTGET (SSNAME exml-ss2 0))))
)
)
(SETQ exml-ss3 exml-ss2))
(T (ALERT "NO CONDITION WAS MET!"))
)
(PRINC "\nAfter .explode command (2) ")
(PRINC)
)
)
)
)
(IF debug-cmd
(ALERT (STRCAT "ENTITY IS " (CDR (ASSOC 0 (ENTGET item-ename)))))
)
)
(SETQ mlcnt (1+ mlcnt)); the last mlcnt set will be 1+ the selection set index of the mtext
(SETQ item-ename (SSNAME exml-ss1 mlcnt))
)
(SETQ mlcnt 0
item-ename2 NIL
txt-lst NIL
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore (WHILE ...) ")
(PRINC)
)
)
(WHILE (AND
exml-ss2
(< mlcnt (SSLENGTH exml-ss2))
(SETQ item-ename2 (SSNAME exml-ss2 mlcnt))
)
(IF (AND
(ENTGET item-ename2)
(EQ (CDR (ASSOC 0 (ENTGET item-ename2)))"TEXT")
)
(IF txt-lst
(SETQ txt-lst (APPEND txt-lst (LIST (ENTGET item-ename2))))
(SETQ txt-lst (LIST (ENTGET item-ename2)))
)
(IF debug-cmd
(IF (ENTGET item-ename2)
(ALERT "item-ename2 is not TEXT!")
(ALERT "(ENTGET item-ename2) is NIL!")
)
)
)
(SETQ mlcnt (1+ mlcnt))
)
(SETQ txtbox-lst NIL)
(IF debug-cmd
(PROGN
(PRINC "\nBefore (FOREACH ...) ")
(PRINC)
)
)
(FOREACH n txt-lst
(IF txtbox-lst
(SETQ txtbox-lst (APPEND txtbox-lst (LIST (CONS (CDR (ASSOC 1 n))(CONS (CDR (ASSOC 10 n))(TEXTBOX n))))))
(SETQ txtbox-lst (LIST (CONS (CDR (ASSOC 1 n))(CONS (CDR (ASSOC 10 n))(TEXTBOX n)))))
)
)
(SETQ max-txtbox NIL)
(IF (EQ (LENGTH txtbox-lst) 1)
(SETQ max-txtbox (CAR(CADDDR (CAR txtbox-lst))) ml-txtbox (LIST (CADDR (CAR txtbox-lst))(CADDDR (CAR txtbox-lst))) txt-txt (CAAR txtbox-lst))
(FOREACH n txtbox-lst
(IF max-txtbox
(IF (>= (CAR(CADDDR n)) max-txtbox)
(SETQ max-txtbox (CAR(CADDDR n)) ml-txtbox (LIST (CADDR n)(CADDDR n)) txt-txt (CAR n))
)
(SETQ max-txtbox (CAR(CADDDR n)) ml-txtbox (LIST (CADDR n)(CADDDR n)) txt-txt (CAR n))
)
)
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore setting points (1) ")
(PRINC)
)
)
(SETQ txt-ins (CADR (CAR txtbox-lst)) ; the insertion point (assoc 10 ...) of the first line of the exploded MTEXT
txt-txt (CAAR txtbox-lst)
last-txt-ins (CADR (LAST txtbox-lst)) ; the insertion point (assoc 10 ...) of the last line of the exploded MTEXT
drop-dist (DISTANCE txt-ins last-txt-ins)
)
(IF debug-cmd
(PROGN
(PRINC "\nAfter setting points (1) ")
(PRINC)
)
)
(SETQ txt-line-cnt (LENGTH txtbox-lst))
(SETQ ldrcnt 0)
(REPEAT (VLA-GET-LEADERCOUNT this-mltobj)
(vla-removeleader this-mltobj ldrcnt)
(setq ldrcnt (1+ ldrcnt))
)
(SETQ lmldr-0 (POLAR
(POLAR txt-ins (-(getvar "viewtwist"))(caar ml-txtbox)) ; left-center of top text line
(+(* PI 0.5)(-(getvar "viewtwist")))
(/(cdr(assoc 41 ml-edata))2.0)
)
lmldr-1 (POLAR lmldr-0 (+(* PI 0.95)(-(getvar "viewtwist"))) (* 1.5(cdr(assoc 41 ml-edata)))); 1st left spline leader point
lmldr-2 (POLAR lmldr-1 (+(-(getvar "viewtwist")) (* PI 0.25)) (*(cdr(assoc 41 ml-edata)) 3.0)); 2nd left spline leader point
lmldr-3 (POLAR lmldr-2 (+(-(getvar "viewtwist")) (* PI 0.75)) (*(cdr(assoc 41 ml-edata)) 4.0)); 3rd left spline leader point
rmldr-0 (POLAR lmldr-0 (-(getvar "viewtwist")) (-(CAADR ml-txtbox)(CAAR ml-txtbox))) ; right-center of top text line
rmldr-1 (IF (= txt-line-cnt 1); 1st right spline leader point
(POLAR rmldr-0 (-(-(getvar "viewtwist"))(* PI 0.05)) (* 1.5(cdr(assoc 41 ml-edata)))); ... when there is only one line of text
(POLAR
(POLAR rmldr-0 ; shift the 1st right spline leader point down by the distance between the first and last leader line when there is more than one line
(-(-(getvar "viewtwist"))(* PI 0.5))
drop-dist ; ... when there is more than one line of text
)
(-(-(getvar "viewtwist"))(* PI 0.05))
(* 1.5(cdr(assoc 41 ml-edata)))
)
)
rmldr-2 (POLAR rmldr-1 (-(-(getvar "viewtwist")) (* PI 0.75)) (*(cdr(assoc 41 ml-edata)) 3.0)); 2nd right spline leader point
rmldr-3 (POLAR rmldr-2 (-(-(getvar "viewtwist")) (* PI 0.25)) (*(cdr(assoc 41 ml-edata)) 4.0)); 3rd right spline leader point
ang-tst (POLAR rmldr-0 (-(getvar "viewtwist")) 40.0); used to test/find correct angles to use above (visually, used with pttxt - point text placement routine)
ang-tst2 (POLAR ang-tst (-(-(getvar "viewtwist"))(* PI 0.05)) 40.0); ditto
)
(if pttxt
NIL
(LOAD "pttxt" "\nFile PTTXT.LSP not loaded! ") ; creates text labels at points for debugging/design
) ;_ end of if
(IF (AND pttxt debugldrpts)
(PROGN
(pttxt "" "lmldr-0" nil nil)
(pttxt "" "lmldr-1" nil nil)
(pttxt "" "lmldr-2" nil nil)
(pttxt "" "lmldr-3" nil nil)
(pttxt "" "rmldr-0" nil nil)
(pttxt "" "rmldr-1" nil nil)
(pttxt "" "rmldr-2" nil nil)
(pttxt "" "rmldr-3" nil nil)
(pttxt "" "ang-tst" nil nil)
(pttxt "" "ang-tst2" nil nil)
)
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore .mleaderedit command (1) ")
(PRINC)
)
)
(command ".mleaderedit" (vlax-vla-object->ename this-mltobj)
"non"
(trans lmldr-1 0 1)
"non"
(trans lmldr-2 0 1)
"non"
(trans lmldr-3 0 1)
""
)
(IF debug-unk
(PROGN
(PRINC "\nmleaderedit (1) ")
(PRINC)
)
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore .mleaderedit command (2) ")
(PRINC)
)
)
(command ".mleaderedit" (vlax-vla-object->ename this-mltobj)
"non"
(trans rmldr-1 0 1)
"non"
(trans rmldr-2 0 1)
"non"
(trans rmldr-3 0 1)
""
)
(IF debug-unk
(PROGN
(PRINC "\nmleaderedit (2) ")
(PRINC)
)
)
(IF debug-cmd
(PROGN
(PRINC "\nAfter .mleaderedit command (2) ")
(PRINC)
)
)
(vla-put-leadertype this-mltobj 2)
(COMMAND ".ERASE" exml-ss1 exml-ss2 "")
(IF debug-unk
(PROGN
(PRINC "\n.ERASE (1) ")
(PRINC)
)
)
(COMMAND "-GROUP" "Explode" ml-grp-name)
(IF debug-unk
(PROGN
(PRINC "\n-GROUP (1) ")
(PRINC)
)
)
(COMMAND "-GROUP" "Explode" ml-grp-name)
(IF debug-unk
(PROGN
(PRINC "\n-GROUP (2) ")
(PRINC)
)
)
(IF C:DEMGroups (C:DEMGroups)); Deletes empty groups... and we made a couple of them!
)
)
(setvar "cmdecho" old-cmdecho)
(setvar "pickstyle" old-pickstyle)
(setvar "osmode" old-osmode)
(if old-ucslist
(cond
((eq (caddr old-ucslist) 1)
(IF debug-cmd
(PROGN
(PRINC "\nBefore .ucs W command ")
(PRINC)
)
)
(command ".ucs" "W"))
((eq (cadr old-ucslist) 1)
(IF debug-cmd
(PROGN
(PRINC "\nBefore .ucs V command ")
(PRINC)
)
)
(command ".ucs" "V"))
((not (eq (car old-ucslist) ""))
(IF debug-cmd
(PROGN
(PRINC "\nBefore .ucs NA command ")
(PRINC)
)
)
(command ".ucs" "NA" "R" (car old-ucslist)))
)
)
(IF debug-cmd
(PROGN
(PRINC "\nBefore .UNDO END command ")
(PRINC)
)
)
(COMMAND ".UNDO" "END")
(SETQ *error* olderror)
(*pop-error-mode*)
(princ)
)
(DEFUN C:AN () (C:AREANOTE))
;;;****************************************************************************
;;; Give me a command to add a leader for when I think that'll be faster than a right-click menu
(DEFUN C:ADDLEADER ( / mldr-ss)
(SETQ mldr-ss (SSGET ":S+." '((0 . "MULTILEADER"))))
(command ".mleaderedit" (SSNAME mldr-ss 0))
)
(DEFUN C:ADL () (C:ADDLEADER))
;;;****************************************************************************
AutoCAD User since 1989. Civil Engineering Professional since 1983
Product Version: 13.6.1963.0 Civil 3D 2024.4.1 Update Built on: U.202.0.0 AutoCAD 2024.1.6
27.0.37.14 Autodesk AutoCAD Map 3D 2024.0.1
8.6.52.0 AutoCAD Architecture 2024
Product Version: 13.6.1963.0 Civil 3D 2024.4.1 Update Built on: U.202.0.0 AutoCAD 2024.1.6
27.0.37.14 Autodesk AutoCAD Map 3D 2024.0.1
8.6.52.0 AutoCAD Architecture 2024
Solved! Go to Solution.
