;;-----------------=={ Copy/Rename Block Reference }==------------------;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright   2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    05-07-2013                                      ;;
;;----------------------------------------------------------------------;;

(defun c:cb nil (LM:RenameBlockReference   t))
(defun c:rb nil (LM:RenameBlockReference nil))

(defun LM:RenameBlockReference ( cpy / *error* abc app dbc dbx def doc dxf new old prp src tmp vrs )

    (defun *error* ( msg )
        (if (and (= 'vla-object (type dbx)) (not (vlax-object-released-p dbx)))
            (vlax-release-object dbx)
        )
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
    
    (while
        (progn
            (setvar 'errno 0)
            (setq src (car (entsel (strcat "\nSelect block reference to " (if cpy "copy & " "") "rename: "))))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'ename (type src))
                    (setq dxf (entget src))
                    (cond
                        (   (/= "INSERT" (cdr (assoc 0 dxf)))
                            (princ "\nPlease select a block reference.")
                        )
                        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 dxf)))))))
                            (princ "\nSelected block is on a locked layer.")
                        )
                    )
                )
            )
        )
    )
    (if (= 'ename (type src))
        (progn
            (setq app (vlax-get-acad-object)
                  doc (vla-get-activedocument app)
                  src (vlax-ename->vla-object src)
                  old (vlax-get-property src (if (vlax-property-available-p src 'effectivename) 'effectivename 'name))
                  tmp 0
            )
            (while (tblsearch "block" (setq def (strcat (vl-string-left-trim "*" old) "_" (itoa (setq tmp (1+ tmp)))))))
            (while
                (and (/= "" (setq new (getstring t (strcat "\nSpecify new block name <" def ">: "))))
                    (or (not (snvalid new))
                        (tblsearch "block" new)
                    )
                )
                (princ "\nBlock name invalid or already exists.")
            )
            (if (= "" new)
                (setq new def)
            )
            (setq dbx
                (vl-catch-all-apply 'vla-getinterfaceobject
                    (list app
                        (if (< (setq vrs (atoi (getvar 'acadver))) 16)
                            "objectdbx.axdbdocument"
                            (strcat "objectdbx.axdbdocument." (itoa vrs))
                        )
                    )
                )
            )
            (if (or (null dbx) (vl-catch-all-error-p dbx))
                (princ "\nUnable to interface with ObjectDBX.")
                (progn
                    (setq abc (vla-get-blocks doc)
                          dbc (vla-get-blocks dbx)
                    )
                    (vlax-invoke doc 'copyobjects (list (vla-item abc old)) dbc)
                    (if (wcmatch old "`**")
                        (vla-put-name (vla-item dbc (1- (vla-get-count dbc))) new)
                        (vla-put-name (vla-item dbc old) new)
                    )
                    (vlax-invoke dbx 'copyobjects (list (vla-item dbc new)) abc)
                    (vlax-release-object dbx)
                    (if cpy (setq src (vla-copy src)))
                    (if
                        (and
                            (vlax-property-available-p src 'isdynamicblock)
                            (= :vlax-true (vla-get-isdynamicblock src))
                        )
                        (progn
                            (setq prp (mapcar 'vla-get-value (vlax-invoke src 'getdynamicblockproperties)))
                            (vla-put-name src new)
                            (mapcar
                               '(lambda ( a b )
                                    (if (/= "ORIGIN" (strcase (vla-get-propertyname a)))
                                        (vla-put-value a b)
                                    )
                                )
                                (vlax-invoke src 'getdynamicblockproperties) prp
                            )
                        )
                        (vla-put-name src new)
                    )
                    (if (= :vlax-true (vla-get-isxref (setq def (vla-item (vla-get-blocks doc) new))))
                        (vla-reload def)
                    )
                    (if cpy (sssetfirst nil (ssadd (vlax-vla-object->ename src))))
                )
            )
        )
    )
    (princ)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
    (strcat
        "\n:: CopyRenameBlock.lsp | Version 1.5 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,$(getvar,date),YYYY)")
        " www.lee-mac.com ::"
        "\n:: Available Commands:"
        "\n::    \"CB\"  -  Copy & Rename Block Reference."
        "\n::    \"RB\"  -  Rename Block Reference."
    )
)
(princ)

;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

However I would really appreciated being able to incorporate three things beyond my skill level:

- Arc Lengths with the prefix "A"

- Mtext output rather than standard Text (I tried simply changing TEXT to MTEXT and a few other tweaks without success)

- Remove trailing 00" (I already have a work around for this but it would be great to have incorporated into the existing lisp)

Any help is greatly appreciated.

;;Bearing and Distance 4 © 2020 Ronald Harman (dlanorh)
;;Released under MIT Licence https://opensource.org/licenses/MIT

(vl-load-com)

(defun rh:R2D (r) (* 180.0 (/ r pi)))

(defun gc:round (num prec) (if (zerop (setq prec (abs prec))) num (* prec (fix ((if (minusp num) - +) (/ num prec) 0.5)))))

(defun rh:midpoint ( pt1 pt2 / pt3 ) (setq pt3 (mapcar '(lambda (x y) (/ (+ x y) 2)) pt1 pt2)))

(defun rh:2azimuth ( a_brg / d a_azi)
  (setq d (fix a_brg))
  (cond ((and (>= d 0) (< d 90)) (setq a_azi (- 90 a_brg)))
        ((and (>= d 90) (< d 180)) (setq a_azi (- 360 (- a_brg 90))))
        ((and (>= d 180) (< d 270)) (setq a_azi (- 270 (- a_brg 180))))
        ((and (>= d 270) (< d 360)) (setq a_azi (- 90 (- a_brg 360))))
  )
  (setq d a_azi)
);_end_defun

; converts radian brg to dms text
(defun rh:2dms ( r_brg rnd / d_brg d m s b_str)
  (setq d_brg (rh:2azimuth (rh:R2D r_brg))
        d (fix d_brg)
        m (fix (* (rem d_brg 1.0) 60))
        s (gc:round (* (rem (* (rem d_brg 1.0) 60) 1.0) 60) rnd)
  );_end_setq
  (if (>= s 59.5) (setq m (1+ m) s 0.0))
  (if (= m 60) (setq d (1+ d) m 0))
  (if (>= d 360) (setq d (- d 360)))
  (setq s (rtos s 2 0) m (itoa m) d (itoa d))
  (if (< (atoi s) 10) (setq s (strcat "0" s)))
  (if (< (atoi m) 10) (setq m (strcat "0" m)))
  ;(while (< (strlen d) 3) (setq d (strcat "0" d)))
  (setq b_str (strcat d "\260" m "'" s "\""))
);_end_defun

(defun rh:em_txt ( pt txt lyr ang tht d72 d73)
  (entmakex (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText")
                 (cons 8 lyr) (cons 50 ang) (cons 7 (getvar 'textstyle)) (cons 1 txt)
                 (cons 10 pt) (cons 40 tht) (cons 72 d72) (cons 11 pt) (cons 73  d73)
            )
  )
);end_defun

;;BEGIN MAIN ROUTINE
(defun C:BAD ( / *error* sv_lst sv_vals tht b_lyr_lst d_lyr_lst lyr_idx d_rnd a_rnd lans pik lyr_e l_lst lt dv txt b_lyr d_lyr l_obj l_ang a_txt l_txt m_pt i_ang d_pt)
(setvar "DIMZIN" 8)
  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );_end_*error*_defun

  (setq sv_lst (list 'cmdecho 'osmode 'dynmode 'dynprompt 'textsize)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq

  (mapcar 'setvar sv_lst '(0 0 3 1))

;; User Variables
  (setq b_lyr_lst (list "Text_3.5 Bearing" "Text_2.8 Bearing Connection") ;; Bearing Layer list (first item is always default)
        d_lyr_lst (list "Text_3.5 Distance" "Text_2.8 Distance Connection") ;; Distance Layer list (first item is always default)
        lyr_idx 0                               ;; Index for the above lists PLEASE DON'T CHANGE
        d_rnd 3                                 ;; Rounding for distance (Integer, number of decimal places)
        a_rnd 5.0                              ;; Rounding for angles (Real Seconds of Arc)
  );end_setq

  (initget "Boundaries Connections")
  (setq lans (cond ( (getkword (strcat "\nUse Boundaries (" (nth lyr_idx b_lyr_lst)" & " (nth lyr_idx d_lyr_lst) ") or Connections Layers : ? [Boundaries/Connections] <Boundaries>"))) ("Boundaries")))
  (if (= lans "Connections") (setq lyr_idx 1 pik "Boundaries") (setq pik "Connections"))

  (setq b_lyr (nth lyr_idx b_lyr_lst) d_lyr (nth lyr_idx d_lyr_lst))

  (foreach lyr (list b_lyr d_lyr) (if (not (tblsearch "layer" lyr)) (setq lyr_e T l_lst (cons lyr l_lst))))

  (cond (lyr_e
          (if (= (length l_lst) 2)  (setq lt "layers" dv " , ") (setq lt "layer" dv ""))
          (setq txt (strcat "MISSING LAYERS\n\nOption " lans " " lt " : "))
          (mapcar '(lambda (x) (setq txt (strcat txt x dv))) l_lst)
          (setq txt (vl-string-right-trim " ," txt))
          (alert (strcat txt "\n\nPlease rectify missing " lt " or re-run\nand select " pik " option"))
        )
  );end_cond (missing layers)

  (initget 6)
  (setq tht (cond ( (getreal (strcat "\nEnter Text Size : <" (rtos (getvar 'textsize) 2 3) ">"))) ( (getvar 'textsize))))

  (cond ( (not lyr_e)
          (princ "\nSelect Lines : ")
          (setq ss (ssget '((0 . "LINE"))))
          (cond (ss
                  (repeat (setq cnt (sslength ss))
                    (setq l_obj (vlax-ename->vla-object (setq ent (ssname ss (setq cnt (1- cnt)))))
                          elst (entget ent)
                          l_ang (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent 0))
                          a_txt (rh:2dms l_ang a_rnd)
                          l_txt (rtos (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2 d_rnd)
                          m_pt (rh:midpoint (vlax-get l_obj 'startpoint) (vlax-get l_obj 'endpoint))
                    );_end_setq
                    (setq i_ang l_ang)
                    (if (and (>= l_ang (* pi 0.5)) (< l_ang (* pi 1.5)))
                      (setq i_ang (- l_ang pi) d_pt (polar m_pt (- i_ang (* pi 0.5)) (* tht 0.3)))
                      (setq d_pt (polar m_pt (- i_ang (* pi 0.5)) (* tht 0.3)))
                    );end_if
                    (rh:em_txt m_pt a_txt b_lyr i_ang tht 1 1)
                    (rh:em_txt d_pt l_txt d_lyr i_ang tht 1 3)
                  );end_repeat
                )
          );end_cond
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);_end_defun
(princ)

Error: bad argument type: numberp: nil
Backtrace:
[0.57] (VL-BT)
[1.53] (#<SUBR @0000018680e21a98 -lambda-> "bad argument type: numberp: nil")
[2.49] (ill-fun-hk "bad argument type: numberp: nil")
[3.44] (((MSG) (IF (NOT (MEMBER MSG (QUOTE ("console break" "Function cancelled" "quit / exit abort" "")))) (PROGN (PRINC (STRCAT "\nError: " MSG)) (IF *DEBUG* (VL-BT))))) "bad argument type: numberp: nil")
[4.39] (_call-err-hook ((MSG) (IF (NOT (MEMBER MSG (QUOTE ("console break" "Function cancelled" "quit / exit abort" "")))) (PROGN (PRINC (STRCAT "\nError: " MSG)) (IF *DEBUG* (VL-BT))))) "bad argument type: numberp: nil")
[5.33] (sys-error "bad argument type: numberp: nil")
:ERROR-BREAK.28 nil
[6.25] (- nil 8.48089)
[7.19] (C:GT)
[8.15] (#<SUBR @0000018680872c50 -rts_top->)
[9.12] (#<SUBR @00000186807c8700 veval-str-body> "(C:GT)" T #<FILE internal>)
:CALLBACK-ENTRY.6 (:CALLBACK-ENTRY)
:ARQ-SUBR-CALLBACK.3 (nil 0)
 

Wasn't that busy, so I thought I'd put together a little Incremental Numbering Suite for you all to sample.

I've come to realise that this kind of LISP seems to be quite a popular one in many trades, and this was my main inspiration for its creation.

As with all my programs - your comments and/or criticism is welcome, as this only helps to improve the program itself.

Thanks & Enjoy!

Cheers

Lee

Incremental Numbering Suite

Main Dialog Preview:

Content Builder Preview:

About Dialog Preview:

A full description of the program and the latest version can be found here.

In the image, I show an example of this. The thick yellow line is part of the original geometry, while the thinner dark-colored line is the one returned by "boundary".
I repeated the command several times, but it always makes the same mistake.
Does anyone understand why this happens?
Is it possible to solve it somehow?

Thanks in advance.

I’m working on a complex borehole location drawing in AutoCAD with many boreholes and corresponding data tables. When a new borehole is added, I would like to have an AutoLISP routine that can automatically place a new table and leader for that borehole without overlapping the existing tables.

The layout concept is roughly like the attached image:

Each borehole is a point/block near the center of the drawing.

Each borehole has a data table placed outside the central cluster.

A leader (polyline or multileader) connects the borehole to its table, using straight segments and preferably angles that are multiples of 60 degrees (or similar fixed angles).

When space on one side is not available, the routine should try other directions until it finds a free spot between the existing tables.

What I would like the routine to do is:

Take the new borehole (block or point) as input.

Use a standard table block (or AutoCAD table) with a known size and insertion point.

Search along several radial directions (0°, 60°, 120°, 180°, 240°, 300° or similar) at a given distance to find a position where the table’s bounding box does not overlap existing tables or a central “no‑go” area.

Insert the new table at the first (or best) free position and draw the leader from the borehole to the table with clean, orthogonal/60° segments.

I have some AutoLISP experience and I’m thinking about using:

Block/table bounding boxes (vla-getBoundingBox) for collision checks.

Simple rectangle overlap tests to avoid collisions.

Polar coordinates for candidate positions at fixed angles and distances.

Before I start building this “placement engine” from scratch, I’d really like your feedback:

Has anyone already written something similar (automatic table/label placement around a central cluster, avoiding overlaps)?

From your experience, is this approach (block + attributes + leader + bounding‑box collision tests) reasonable, or is there a better pattern?

Any tips on robust overlap detection or examples of similar LISP routines you recommend looking at?

Would you implement this with standard tables, block attributes, or something else for the borehole information ?

Any ideas, sample code, or links to existing routines would be greatly appreciated. Thanks in advance for your time and suggestions!

** Find attached plz

11.pdf

 When executed, the utility launches an interactive keyword configuration:  

 Menu: [1-Polylines/2-Lines/3-Arcs/4-Circles/5-Splines/6-FeatureLines/7-All] 

 --- OPTION 1: Polylines ---                                                

  - Target: Native 2D LWPolylines and 3D Heavy Polylines (*POLYLINE).       

  - Sub-Prompts: Asks for both "Curve distance" and "Line distance".         

  - Workflow Logic: Polylines frequently alternate between straight tangents 

    and arced bulges. The engine runs through each sub-segment parameter,   

    applying the Curve interval on loops returning a non-zero bulge and the 

    Line interval on zero-bulge vectors. Critical for tracking centerlines. 

 --- OPTION 2: Lines ---                                                    

  - Target: Standalone native LINE entities (completely ignores curves).    

  - Sub-Prompts: Triggers only "Line distance [Middle/Vertices]".           

  - Workflow Logic:                                                         

    * Absolute Number: Measures out fixed structural intervals from start.  

    * "Middle": Drops a single layout node at exactly Total Length / 2.      

    * "Vertices": Flags only the absolute start and endpoints, bypassing    

       any segment division calculations. Perfect for boundary box indexing. 

 --- OPTION 3: Arcs ---                                                     

  - Target: Standalone open circular ARC elements.                          

  - Sub-Prompts: Triggers only "Curve distance [Middle]".                  

  - Workflow Logic: Uses true structural arc-length path calculations (not  

    straight-line chord spacing). Entering "Middle" isolates the exact apex 

    mid-curve station node. Excellent for curb returns or radius layout.    

 --- OPTION 4: Circles ---                                                  

  - Target: Full, closed 360-degree CIRCLE elements.                        

  - Sub-Prompts: 1. Circle Mode [Distance/Pieces]                           

                 2. Curve Distance (if Distance Mode)                       

                 3. Number of Slices (if Pieces Mode)                       

  - Workflow Logic:                                                         

    * Pieces Mode: Divides the 360° rim into perfectly equal pie sections.  

      Ideal for setting layout coordinates for manholes or foundation piles. 

    * Distance Mode: Steps linearly around the outer circumference.         

 --- OPTION 5: Splines ---                                                 

  - Target: Non-uniform smooth organic SPLINE curve strings.                

  - Sub-Prompts: Triggers "Curve distance" and "Line distance".             

  - Workflow Logic: Utilizes Visual LISP curve projection vectors to step   

    smoothly through changing multi-radius landscape or contour paths,      

    automatically trapping and marking the true start/end index boundaries. 

 --- OPTION 6: FeatureLines ---                                            

  - Target: Native Autodesk Civil 3D Feature Lines (AECC_FEATURE_LINE).     

  - Sub-Prompts: Triggers "Curve distance" and "Line distance".             

  - Workflow Logic: Tailored for civil infrastructure models. The engine    

    interrogates the 3D string, locks all critical grade breaks and site    

    vertices, and overlays intermediate interval layout points that retain  

    design model accuracy.                                                  

 --- OPTION 7: All ---                                                      

  - Target: Simultaneous mixed selection set of all supported geometries.  

  - Sub-Prompts: Sequential configuration parameters for all curves/lines.  

  - Workflow Logic: Scans the entire cross-window selection. For every object

    trapped, it reads its DXF Group 0 type, dynamically assigns your preset 

    rules, avoids duplicate coordinate overlaps, and populates the entire   

    site plan layer in a single execution click.        

 SHORT SEGMENT OVERRIDE LOGIC:                                              

 If an entity length or sub-segment is shorter than the interval distance   

 specified, the script halts and prompts: [Middle/All/SkipAll]              

  - "Middle": Drops a layout node exactly at the center of that specific    

    short segment.                                                          

  - "All": Converts the current short vector and all subsequent short vectors

    discovered during the current command run into midpoints automatically. 

  - "SkipAll": Ignores short segments entirely for the rest of the execution,

    leaving them clean and checking only major length spans.   
 

 SHORT SEGMENT OVERRIDE LOGIC:                                             

 If an entity length or sub-segment is shorter than the interval distance  

 specified, the script halts and prompts: [Middle/All/SkipAll]             

  - "Middle": Drops a layout node exactly at the center of that specific   

    short segment.                                                         

  - "All": Converts the current short vector and all subsequent short vectors

    discovered during the current command run into midpoints automatically.

  - "SkipAll": Ignores short segments entirely for the rest of the execution,

    leaving them clean and checking only major length spans.               

Is there a way to explode nested blocks within a block without exploding the original block that is shown in my drawing?

Any help would be greatly appreciated.

https://sourceforge.net/projects/nppactivexplugin/

and have just gone around in circles trying to join so could send a message re problem, is anyone else having problems ? Do you have a sourceforge account and could send a message would be appreciated.

; This routine runs the code in the active editor of NotePad++ from AutoCAD:
(defun C:n++ nil (C:RunFromNotePadPP)) ; Quick Run
(defun C:RunFromNotePadPP ( / scr *error* err np++ npeditor npSS npMS r )
  ; NOTE: Requires ActiveX plugin(by David Gausmann) installed on the NP++ 
  ; https://sourceforge.net/projects/nppactivexplugin/
 
  (defun *error* (m)
    (foreach x (reverse (list np++ npeditor npSS npMS))
      (vl-catch-all-apply (function vlax-release-object) (list x))
    )
    (gc) (gc)
    (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)))) (princ)
  ); defun *error*
 
  (setq err
    (vl-catch-all-apply
      (function 
        (lambda nil ; THIS WORKS - IT GETS THE ACTIVE DOCUMENT CODE IN NOTEPAD !!!
          (setq np++ (vlax-get-or-create-object "NotepadPlusPlus.Application"))
          (setq npeditor (vlax-get np++ 'ActiveEditor))
          (vlax-invoke-method npeditor 'selectAll)
          (setq npSS (vlax-get npeditor 'selections))
          (setq npMS (vlax-get npSS 'mainSelection))
          (setq r (vlax-get-property npMS 'text))
          (vlax-invoke npSS 'setRange 0 0 0 0)
        ); lambda 
      ); function
    ); vl-catch-all-apply
  ); setq err 
 
  (*error* nil)(princ)
  (if (and r (not (vl-catch-all-error-p err)))
    (eval (read (strcat "(list\n" r "\n)")))
  )
); defun

The diesel code that works is below.

attdia;0;-I;REVNOTE;\;1;;P01;""$m=$(edtime,$(getvar,date),DD.MO.YYYY)"";SMS;First issue;;attdia;1;rea;

The same in lisp below

(command "attdia" "0")
(command "_Insert" "REVNOTE" pause 1 1 0 "P01" Date Initials pause)
(command "attdia" "1")
(command "REA")

Any ideas on why this is happening as i'm stumped, unless its a bug in AutoCAD. 

many thanks

REVNOTE.dwg

Most info included in lisp file. Just a quick string search for lsp, txt & dwg files.

Start with QSS , select folder , extension like lsp,dwg and search string like Rlx

Type in extensions like lsp,txt (with comma) and for text use pipe symbol like Rlx|Dragon

for now only lsp,txt and dwg are supported , haven't been able to make it work on pdf

I have added a couple of toggles , Shadow mode , Recovery & Everything.

Shadow mode writes a log file for every file that is searched. Next to it is Recovery.

When searching oh lets say 100.000+ files and one of the files is corrupt AutoCad crashes and all previous results are poof...

When this happens start AutoCad again , select Recovery , and app will continue the search by comparing the complete file-list

with the shadow list and can work out from where to continue and put corrupt drawing on the naughty list.

These files are saved on desktop in QuickSearchFolder.

If a drawing was saved with a higher version I can error-catch that but when a file is corrupt lisp can't handle that so hence the recovery option.

When multiple drawings are corrupt you have to repeat this process as many times until app reaches the finish line.

When the list pops up you only see the matches found from the last successful run, click on the load button and shadow list is read again et voila.

When 'Everything' is selected all text from all files (drawings) are saved to a text file.

Button Clear Lists in main dialog deletes all files from desktop folder so you can start as fresh as a baby's butt (after a bath of course)

Also corrected a little bug in the get-subfolders routine. Within the code I was working on doc/docx & pdf support but they are so slow I removed them from extension filter , but if you want to try uncomment line 285 and comment line 286

RlxSplit.lsp

I have been racking my brains to amend this lisp to do what i want and have failed.... so i ask you the gods of lisp for some help.

I have acquired a lisp file via google AI that will set the elevation (z axis) of a poly line, easier to just select the pline and type in the elevation i hear you cry....

But my cunning plan was to amend the elevation of said pline by selecting the pline then select the text/mtext next to it.....

I thought i could add some command to do this by looking at another lisp i have that does a similar thing, but i am a numpty and have given up....

I know there are many wise men out there that could just type some lines with their eyes shut and solve my problem...

Obviously i would be greatly indebted to such persons and wish boundless fortune upon them granting wishes galore if i could...

Also I just want an easy life as i approach retirement and thinking for gets in the way of thinking for myself.....

Begging you nicely..

Paul

SetPlineZ.lsp

The lisp routine here supports automatic  projection between lines, custom perpendicular line generation, and  manual adjustment of slopes.
The explanation for its functions within the routine.
Regards.

3DSLOPE-automates the creation of 3D Polylines, level labels, and slope percentages.LSP

I've been a lurker on CADTutor for years and learned 

a lot from this community, so I wanted to share 

something I built and get feedback from people who 

actually know LISP.

Background: I'm a civil CAD drafter working on US 

land development projects — grading, drainage, 

easements, corridors. MLINE has always been the 

tool I wanted to use for drawing parallel offset 

lines but couldn't, mainly because the objects are 

locked, there's no lineweight control per component, 

and the .mln style management across a team is a 

nightmare. So I wrote a replacement.

──────────────────────────────────

WHAT IT DOES

──────────────────────────────────

Command MPL works like PLINE — you draw a centerline 

and it generates a set of configurable parallel 

LWPOLYLINEs around it. Every satellite line is a 

real polyline: fully grip-editable, trimmable, 

offsettable, joinable. No locked geometry, no 

exploding required.

Each satellite line carries its own:

- Offset distance (positive = left, negative = right)

- Layer (Pro version)

- Color, linetype, lineweight, linetype scale

Configuration is handled through a DCL dialog 

(MPLEDIT). Settings save as user defaults and, 

in the Pro version, as named presets stored in 

%APPDATA%\MplineAuto\presets.dat.

──────────────────────────────────

TWO VERSIONS

──────────────────────────────────

Lite (free .lsp):

- MPL, MPLEDIT, MPLSYNC

- Manual sync after edits — run MPLSYNC, 

  window-select the group, done

- Groups are tracked via XDATA (app tag: MPLINE_PIPE)

Pro (compiled .vlx, $29.49):

- Everything in Lite plus:

- Command reactor for auto-sync — watches masters 

  before/after every command, diffs vertex lists, 

  rebuilds only what changed

- Named preset library with Save/Update/Delete 

  from the dialog

- Per-satellite layer assignment

- MPLADD — promote existing LWPOLYLINEs or LINEs 

  into MPL groups

- MPLON / MPLOFF — toggle reactor at runtime

- XDATA app tag: MPLINE_AUTO

──────────────────────────────────

IMPLEMENTATION NOTES

──────────────────────────────────

The interesting part was the Pro reactor. I went 

through a few approaches before landing on a global 

command reactor that snapshots the master cache 

before a command fires and diffs it after. This 

avoids object reactors entirely (which caused IDispatch 

arity issues in testing) and means the reactor 

doesn't interfere with Express Tools or COPY/MIRROR 

operations on non-MPL geometry.

Groups copied with COPY or MIRROR produce new masters 

on the next MPLSYNC call — the reactor doesn't 

auto-register copies, which is intentional to avoid 

unexpected geometry multiplication.

Happy to discuss the approach if anyone has thoughts 

or has solved similar problems differently.

──────────────────────────────────

LINKS

──────────────────────────────────

Video walkthrough: https://youtu.be/DXpyy1JWtXs

Free Lite download: 

https://skillamplifier.gumroad.com/l/hgpujs

Pro listing: 

https://skillamplifier.gumroad.com/l/nsidsv

Blog post with full documentation and use cases:

https://skillamplifier.wordpress.com/2026/05/16/multipline/

Full disclosure: I'm the developer. Posting here 

because I'd genuinely value feedback from experienced 

LISP users, and the Lite version is free so there's 

no risk trying it.

Thanks for any thoughts.

Zlatislav

TBC- JOIN TEXT AND POLYLINES AND CONVERT THEM TO MLEADER OR MAKE IT MANUALLY.lsp BR FIN LVLS-1.dwg

(defun c:KKK ( / TBName TBTemp s flag ctr SheetSize chk PrjName LaynName i n e x 1p 2p o1p o2p y1p y2p s1 i1 n1 e1 x1 s2 i2 n2 e2 x2 Psize Size file tempViewName DwgTitle )
  
  (setvar "CMDECHO" 0)

  (setq TBName "Title Block_R2.R")
  (setq TBTemp "FT NEW TEMPLATE 2.0")
  (setq s nil)
  (setq flag 1)
  (setq ctr 1)
  (setq SheetSize nil)
  (setq chk nil)
  (setq LaynName (car (layoutlist)))
  (setq DwgTitle "Title_info")
  (setq tempViewName "_TEMP_ORIGINAL_VIEW")
  
  (if (setq s (ssget (list '(0 . "INSERT") )))
        (progn
            (command "-VIEW" "S" tempViewName)
            (setq chk T)
            (setq i 0
                  n (sslength s)
            )
            (while (< i n)
                (setq e (ssname s i)
                      x (cdr (assoc 2 (entget e)))
                      i (1+ i)
                )
              ;(print x)
                (if (= (LM:name->effectivename x) TBName )
                  (progn
                    (command "_zoom" "_object" (cdr(car(entget e))) "")
                    (setq 1P (car(LM:boundingbox (vlax-ename->vla-object (cdr(car(entget e)))))))
                    (setq 2P (nth 2 (LM:boundingbox (vlax-ename->vla-object (cdr(car(entget e)))))))
                    (setq o1P 1P)
                    (setq o2P 2P)
                    (setq y1p (strcat (rtos (car 1P) 2 0) "," (rtos (car (cdr 2P)) 2 0)))
                    (setq y2p y1p)
                    
                    (setq s1 (ssget "W" 1P 2P (list '(0 . "INSERT") )))
                    
                                (setq i1 0
                                      n1 (sslength s1)
                                )
                                (while (< i1 n1)
                                  (setq e1 (ssname s1 i1)
                                      x1 (cdr (assoc 2 (entget e1)))
                                      i1 (1+ i1)
                                  )
                                  
                                  (if (= (cdr (assoc 0 (entget e1))) "INSERT")
                                    (cond 
                                      ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e1))))) "NESTED")
                                        (setq SheetSize (LM:assoc++ (setq Size (strcat (LM:getattributevalue (cdr (car(entget e1))) "SHEET_WIDTH") "X" (LM:getattributevalue (cdr (car(entget e1))) "SHEET_HEIGHT"))) SheetSize))
                                        (setq PSize (assoc Size SheetSize))
                                        (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                                        
                                      )
                                      ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e1))))) "SINGLE PANEL")
                                        (setq s2 (ssget "W" (subst (- (car 1p) 450) (car 1p) 1p) 2P (list '(0 . "INSERT") )))
                                        (setq i2 0
                                                    n2 (sslength s2)
                                              )
                                              (while (< i2 n2)
                                                  (setq e2 (ssname s2 i2)
                                                        x2 (cdr (assoc 0 (entget e2)))
                                                        i2 (1+ i2)
                                                  )
                                                (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "NestedPanelTitle")
                                                  (setq Psize (LM:getattributevalue (cdr (car(entget e2))) "PANELNAME"))
                                                )
                                                (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "AWC")
                                                  (LM:setattributevalue e2 "RUN_PROGRAM" "-")
                                                )
                                              ) 
                                            
                                      )
                                      ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e1))))) "NESTED (OFFCUT)")
                                        (setq SheetSize (LM:assoc++ "OFFCUT" SheetSize))
                                        (setq PSize (assoc "OFFCUT" SheetSize))
                                        (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                                        
                                      )
                                       ((= x1 DwgTitle)
                                       (setq PrjName (vl-string-trim "Model" (LM:getattributevalue e1 "PROGRAM_NAME:")))

                                      ) 
                                    );cond
                                  );if
                                );while
                  );progn
                );if
            )
          (if (= PSIZE nil)
            (setq flag 0)
            (progn
              
              (CreateScript)
            )
          )
        )
    (progn
    (setq flag 0)
    (setq ctr 0)
    )
    );if
    (princ)
  
  
(while (= flag 1)
  (while (= ctr 1)
    (setq 1P (list (car 1P)(- (car(cdr 1P)) 4127 )))
    (setq 2P (list (car 2P)(- (car(cdr 2P)) 4127 )))
    (setq y1p (strcat (rtos (car 1P) 2 0) "," (rtos (car (cdr 2P)) 2 0)))
    
    (command "._zoom" "non" 1P "non" 2P)
    
    (if (setq s (ssget "_W" 1P 2P)) 
        (progn
            (setq i 0
                  n (sslength s)
            )
            (while (< i n)
                (setq e (ssname s i)
                      x (cdr (assoc 0 (entget e)))
                      i (1+ i)
                )
              (if (= x "INSERT")
                (cond 
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED")
                    (setq SheetSize (LM:assoc++ (setq Size (strcat (LM:getattributevalue (cdr (car(entget e))) "SHEET_WIDTH") "X" (LM:getattributevalue (cdr (car(entget e))) "SHEET_HEIGHT"))) SheetSize))
                    (setq PSize (assoc Size SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteScript)
                    (setq ctr 1)
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "SINGLE PANEL")
                    (setq s2 (ssget "W" (subst (- (car 1p) 450) (car 1p) 1p) 2P (list '(0 . "INSERT") )))
                    (setq i2 0
                                n2 (sslength s2)
                          )
                          (while (< i2 n2)
                              (setq e2 (ssname s2 i2)
                                    x2 (cdr (assoc 0 (entget e2)))
                                    i2 (1+ i2)
                              )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "NestedPanelTitle")
                              (setq Psize (LM:getattributevalue (cdr (car(entget e2))) "PANELNAME"))
                            )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "AWC")
                              (LM:setattributevalue e2 "RUN_PROGRAM" "-")
                            )
                          ) 
                    (WriteScript)
                    (setq ctr 1)
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED (OFFCUT)")
                    (setq SheetSize (LM:assoc++ "OFFCUT" SheetSize))
                    (setq PSize (assoc "OFFCUT" SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteScript)
                    (setq ctr 1)
                  )
                );cond
                
              )
            );WHILE
        );PROGN
    );IF
    (if (= s nil) (setq ctr 0))
    (princ)
  );while
    (setq 1P (list (+ (car o1P) 6830 )(car(cdr o1P))))
    (setq 2P (list (+ (car o2P) 6830 )(car(cdr o2P))))
    (setq y1p (strcat (rtos (car 1P) 2 0) "," (rtos (car (cdr 2P)) 2 0)))
    (setq o1P 1P)
    (setq o2P 2P)
    (command "_zoom" 1P 2P)
  
    (if (setq s (ssget "_W" 1P 2P))
        (progn
            (setq i 0
                  n (sslength s)
            )
            (while (< i n)
                (setq e (ssname s i)
                      x (cdr (assoc 0 (entget e)))
                      i (1+ i)
                )
              
              (if (= x "INSERT")
                (cond 
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED")
                    (setq SheetSize (LM:assoc++ (setq Size (strcat (LM:getattributevalue (cdr (car(entget e))) "SHEET_WIDTH") "X" (LM:getattributevalue (cdr (car(entget e))) "SHEET_HEIGHT"))) SheetSize))
                    (setq PSize (assoc Size SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteNextScript)
                    (setq ctr 1)
                    
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "SINGLE PANEL")
                    (setq s2 (ssget "W" (subst (- (car 1p) 450) (car 1p) 1p) 2P (list '(0 . "INSERT") )))
                    (setq i2 0
                                n2 (sslength s2)
                          )
                          (while (< i2 n2)
                              (setq e2 (ssname s2 i2)
                                    x2 (cdr (assoc 0 (entget e2)))
                                    i2 (1+ i2)
                              )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "NestedPanelTitle")
                              (setq Psize (LM:getattributevalue (cdr (car(entget e2))) "PANELNAME"))
                            )
                            (if (= (LM:name->effectivename (cdr (assoc 2 (entget e2)))) "AWC")
                              (LM:setattributevalue e2 "RUN_PROGRAM" "-")
                            )                            
                          ) 
                    (WriteNextScript)
                    (setq ctr 1)
                    
                  )
                  ((= (LM:getvisibilitystate (vlax-ename->vla-object (cdr (car (entget e))))) "NESTED (OFFCUT)")
                    (setq SheetSize (LM:assoc++ "OFFCUT" SheetSize))
                    (setq PSize (assoc "OFFCUT" SheetSize))
                    (setq Psize (strcat (car Psize)"-" (fixitoa (cdr Psize) 2)))
                    (WriteNextScript)
                    (setq ctr 1)
                  )
                  
                );cond
                
              )
            );WHILE
        );PROGN
    );IF
  
  (if (= nil s)(setq flag 0))
);while
  (DelAllLayout)
  (if (= chk nil)
    (princ "\nInvalid Object")
      (progn
        (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "A"))
        (write-line "LockAllVp" file)
        (write-line "MODEL" file)
        (write-line (strcat "-VIEW\tR " tempViewName "\n ") file)
        (write-line (strcat "-VIEW\tD " tempViewName "\n ") file)
        (write-line "REGENALL" file)
        (close file)
        (command "_.Layout" "Set" (car (layoutlist)))
        (command "_.script" (strcat (getvar "dwgprefix") "CreateScript.scr"))
      )
  )
  (setvar "CMDECHO" 1)
  (princ)
);defun

;=========================================================================

(defun LM:name->effectivename ( blk / rep )
  (if
    (and  (wcmatch blk "`**")
          (setq rep
            (cdadr
              (assoc -3
                (entget
                  (cdr (assoc 330 (entget (tblobjname "block" blk))))
                    '("AcDbBlockRepBTag")
                )
              )
            )
          )
          (setq rep (handent (cdr (assoc 1005 rep))))
    )
    (cdr (assoc 2 (entget rep)))
      blk
  )
)

;=========================================================================

(defun LM:boundingbox ( obj / a b lst )
    (if
        (and
            (vlax-method-applicable-p obj 'getboundingbox)
            (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
            (setq lst (mapcar 'vlax-safearray->list (list a b)))
        )
        (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
           '(
                (caar   cadar)
                (caadr  cadar)
                (caadr cadadr)
                (caar  cadadr)
            )
        )
    )
)

;=========================================================================

(defun LM:getattributevalue ( blk tag / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
            (cdr (assoc 1 (reverse enx)))
            (LM:getattributevalue blk tag)
        )
    )
)

;=========================================================================

(defun LM:setattributevalue ( blk tag val / enx )
    (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
        (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
            (if (entmod (subst (cons 1 val) (assoc 1 (reverse enx)) enx))
                (progn
                    (entupd blk)
                    val
                )
            )
            (LM:setattributevalue blk tag val)
        )
    )
)

;=========================================================================

(defun LM:effectivename ( obj )
    (vlax-get-property obj
        (if (vlax-property-available-p obj 'effectivename)
            'effectivename
            'name
        )
    )
)

;=========================================================================

(defun LM:assoc++ ( key lst / itm )
    (if (setq itm (assoc key lst))
        (subst (cons key (1+ (cdr itm))) itm lst)
        (cons  (cons key 1) lst)
    )
)

;=========================================================================

(defun CreateScript ()
  (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "W"))
  (write-line (strcat ".mview\tL\tOFF\tALL \nLAYOUT\tR\t" LaynName "\t" "-") file)
  (write-line (strcat "LAYOUT\tR\t" "-" "\t" PSize) file)
  (close file)
  (setq LaynName PSize)
  (crText (mapcar '+ '(150 2200) (list (car 1p) (cadr 1p))) 75 (strcat PrjName laynname))
)

;=========================================================================

(defun WriteScript ()
  
  (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "A"))
  (write-line (strcat "LAYOUT\tC\t" LaynName "\t" PSize "\tLAYOUT\tS\t" PSize "\tGoLast\tMspace\t-pan\t" y1p "\t" y2p "\tPspace") file)
  (close file)
  (setq LaynName PSize)
  (setq y2p y1p)
  (crText (mapcar '+ '(150 2200) (list (car 1p) (cadr 1p))) 75 (strcat PrjName laynname))
)

;=========================================================================

(defun WriteNextScript ()
  (setq file (open (strcat (getvar "dwgprefix") "CreateScript.scr") "A"))
  (write-line (strcat "LAYOUT\tC\t" LaynName "\t" PSize "\tLAYOUT\tS\t" PSize "\tGoLast\tMspace\t-pan\t" y1p "\t" y2p "\tPspace") file)
  (close file)
  (setq LaynName PSize)
  (setq y2p y1p)
  (crText (mapcar '+ '(150 2200) (list (car 1p) (cadr 1p))) 75 (strcat PrjName laynname))
)

;=========================================================================

(defun fixitoa ( #i #n / s ) (setq s (itoa #i))(while (> #n (strlen s))(setq s (strcat "0" s))) s)

;=========================================================================

(defun LM:getvisibilitystate ( blk / vis )
    (if (setq vis (LM:getvisibilityparametername blk))
        (LM:getdynpropvalue blk vis)
    )
)

;=========================================================================

(defun LM:getvisibilityparametername ( blk / vis )  
    (if
        (and
            (vlax-property-available-p blk 'effectivename)
            (setq blk
                (vla-item
                    (vla-get-blocks (vla-get-document blk))
                    (vla-get-effectivename blk)
                )
            )
            (= :vlax-true (vla-get-isdynamicblock blk))
            (= :vlax-true (vla-get-hasextensiondictionary blk))
            (setq vis
                (vl-some
                   '(lambda ( pair )
                        (if
                            (and
                                (= 360 (car pair))
                                (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
                            )
                            (cdr pair)
                        )
                    )
                    (dictsearch
                        (vlax-vla-object->ename (vla-getextensiondictionary blk))
                        "ACAD_ENHANCEDBLOCK"
                    )
                )
            )
        )
        (cdr (assoc 301 (entget vis)))
    )
)

;=========================================================================

(defun LM:getdynpropvalue ( blk prp )
    (setq prp (strcase prp))
    (vl-some '(lambda ( x ) (if (= prp (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
        (vlax-invoke blk 'getdynamicblockproperties)
    )
)

;=========================================================================

(defun DelAllLayout ( / ll)
  (command "_.Layout" "Set" (car (getLayoutOrderList)))
  (while (/= 0 (setq ll (- (setq ll (length (getLayoutOrderList))) 1 )))
      (progn 
        (if (> ll 0)
          (command "_-LAYOUT" "DELETE" (nth ll (getLayoutOrderList)))
        )
      );progn 
  );while
  (command "Model")
)

;=========================================================================

(defun getLayoutOrderList( / lst mklist mappend flatten)
    (defun mklist (x) (if (listp x) x (list x)))
    (defun mappend (fn lst)(apply 'append (mapcar fn lst))) 
    (defun flatten (expr)(mappend 'mklist expr))
    (vlax-for lay 
        (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
        (setq lst (cons (list (vla-get-taborder lay)(vla-get-name lay)) lst))
    )
    (cdr(flatten(mapcar 'cdr (vl-sort lst '(lambda (a b) (< (car a)(car b)))))))
)

;=========================================================================

(defun c:GoLast (/ l)

  (if (and (< 2
              (vla-get-count
                (setq l (vla-get-Layouts
                          (vla-get-ActiveDocument (vlax-get-acad-object))
                        )
                )
              )
           )
           (eq 0 (getvar 'TILEMODE))
      )
    (vla-put-taborder
      (vla-item l (getvar 'CTAB))
      (1- (vla-get-count l))
    )
    (princ "\n ** Command is not allowed in Model Space **")
  )
  (princ)
)

;=========================================================================

(defun C:LockAllVp ( / i oldlo oldcmde)
 (setq oldcmde (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (setq oldlo (getvar "CTAB"))
;cannot lock model
; (setvar "CTAB" "Model")
;all layouts
 (foreach i (layoutlist)
  (progn 
   (setvar "CTAB" i)
   (command "_-VPORTS" "_Lock" "_on" "_all" "")
   );progn 
 )
 (setvar "CTAB" oldlo)
 (setvar "CMDECHO" oldcmde)
 (princ "\nAll viewports locked.")
 (princ)
)

;=========================================================================

(defun crText ( ins hgt str / ent )
  (entmake 
    (list 
      '(000 . "TEXT")      
      '(100 . "AcDbText")
      '(7 .   "TEXT")
      '(8 .   "Defpoints")
      (cons 010 ins)      
      (cons 040 hgt)      
      (cons 001 str)      
    )
  )
)

;=========================================================================

  (defun *error* (msg)
    (if (not (wcmatch msg "quit/exit abort,function canceled"))
      (princ (strcat "\nError: " msg)) ; Display message for actual errors
    )
    (setvar "CMDECHO" 1) ; Ensure settings are reset
    (princ) ; Quiet exit
  )

;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(princ
    (strcat
        "\n:: Version 1.1 | \\U+00A9 FT ::"
        "\n:: This Progam also works with Single Panel ::"
        "\n:: \"CRL\" to Create Layout ::"
    )
)
(princ)

GTTB-BATCH-COPY ANY NUMBER OF TEXTS TO ATTRIB BLOCKS.LSP rec2txt-placing a specific object (like a .lsp H B2 FINISHS - ATT-2.dwg

I have a lisp which get the X & Y coordinates with leader, text. But it would be very useful if the coordinates comes with MLEADER (Text/Arrow height - 2.5).

Please help me out here anyone