Leaderboard

Here's a simpe solution that doesn't use LISP. Change the elevation of one of the polylines to 1.0 then use the loft command to create asurface. Section the resulting surface with an XY plane at 0,0,0.5.

Calculating an axis using angle bisectors a) Attempt number 1 (it was my first impulse, but I came up with a better one later) Advantages: - Pure LISP: doesn't depend on Express Tools, - It's faster Disadvantages: - The result isn't as good as @GP_'s "c:CPL" - It only accepts LWPOLYLINES and ignores arcs Basically, the approach is to obtain angle bisectors on each polyline, extend them to the other reference polyline, and use their midpoints. The result is acceptably good, but not as accurate as c:CPL. (defun c:creAxis (/ e e1 e2 l1 l2 lr p p0 p1 p2 px pm abis lii pmi pfi pi1 pi2 pf1 pf2 dameInters+Prox ordena) (defun dameInters+Prox (p0 a lp / p1 px pt1 pt2 dmin d pf) (setq pt1 (polar p0 a 1e8) pt2 (polar p0 (+ a PI) 1e8)) (foreach p lp (if p1 (if (setq px (inters pt1 pt2 p1 p)) (if dmin (if (< (setq d (distance px p0)) dmin) (setq dmin d pf px)) (setq dmin (distance px p0) pf px)) ) ) (setq p1 p) ) pf ) (defun ordena (pr lp / d dmin ps lr) (while lp (foreach p lp (if dmin (if (< (setq d (distance p pr)) dmin) (setq dmin d ps p) ) (setq dmin (distance p pr) ps p) ) ) (setq dmin nil pr ps lp (vl-remove ps lp) lr (append lr (list ps))) ) ) (if (and (setq e1 (car (entsel "\nSelect first LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l1 (entget e1)))) "LWPOLYLINE") (not (redraw e1 3))) (if (and (setq e2 (car (entsel "\nSelect second LWPOLYLINE..."))) (= (cdr (assoc 0 (setq l2 (entget e2)))) "LWPOLYLINE") (not (redraw e2 3))) (progn (setq lp1 (reverse (foreach l l1 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil; lp2 (reverse (foreach l l2 (if (= (car l) 10) (setq lr (cons (cdr l) lr)) lr))) lr nil; ) (if (< (distance (setq pi1 (cdr (assoc 10 l1))) (setq pi2 (cdr (assoc 10 l2)))) (distance pi1 (setq pf2 (cdr (assoc 10 (reverse l2)))))) (setq pmi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) pi1 pi2) pfi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (setq pf1 (cdr (assoc 10 (reverse l1)))) pf2) ) (setq pmi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) pi1 pf2) pfi (mapcar '(lambda (a b) (/ (+ a b) 2.0)) (cdr (assoc 10 (reverse l1))) pi2) ) ) (redraw e1 4) (redraw e2 4) (foreach l l1 (if (= (car l) 10) (if p1 (if p2 (setq abis (+ (/ (+ (angle p1 p2) (angle p2 (cdr l))) 2) (/ PI 2.)) x (princ) px (dameInters+Prox p2 abis lp2) lr nil pm (if px (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p2 px)) lii (if px (append lii (list pm)) lii) p1 p2 p2 (cdr l) ) (setq p2 (cdr l)) ) (setq p1 (cdr l)) ) ) ) (setq p1 nil p2 nil lr nil) (foreach l l2 (if (= (car l) 10) (if p1 (if p2 (setq abis (+ (/ (+ (angle p1 p2) (angle p2 (cdr l))) 2.) (/ PI 2.)) px (dameInters+Prox p2 abis lp1); pm (if px (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p2 px) (princ) ) lii (if px (append lii (list pm)) lii); p1 p2 p2 (cdr l) ) (setq p2 (cdr l)) ) (setq p1 (cdr l)) ) ) ) (setq lii (append (list pmi) (ordena pmi lii) (list pfi))) ) ) ) (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (70 . 0) (60 . 0)) (list (cons 90 (length lii))) (mapcar '(lambda (a) (cons 10 a)) lii))) (princ) ) PS: It seems to work well, but I haven't tested it extensively. As I said at the beginning, there's a better approach, using angle bisectors, which I'll publish later.

Long time I'm nothing written in Lisp. So, I hoppe it will serve you. Also, you can saw a short video how it works. The code: (prompt "\nTo run a LISP type: yval") (princ) (defun c:yval ( / old_osmode pline spt ept spt_pline ept_pline datum_line yval_datum_line yval_start_pline yval_end_pline txt_position ang_spt_pline ang_ept_pline datum_value intersecting_lines len i int_pt_pline int_pt_datum_line dist yval_position ang) (setq old_osmode (getvar 'osmode)) (setq pline (car (entsel "\nSelect Polyline to get an Elevation:"))) (while (or (equal pline nil) (not (equal "LWPOLYLINE" (cdr (assoc 0 (entget pline)))))) (prompt "\nSelected entity must be LWPOLYLINE. Try again...\n") (setq pline (car (entsel "\nSelect Polyline to get an Elevation:"))) ) (setq spt_pline (vlax-curve-getStartPoint pline) ept_pline (vlax-curve-getEndPoint pline) ) (if (> (car spt_pline) (car ept_pline)) (progn (command-s "_reverse" pline "") (setq spt_pline (vlax-curve-getStartPoint pline) ept_pline (vlax-curve-getEndPoint pline) ) ) ) (setq datum_line (car (entsel "\nSelect Datum Line:"))) (while (or (equal datum_line nil) (not (equal "LINE" (cdr (assoc 0 (entget datum_line)))))) (prompt "\nSelected entity must be LINE. Try again...\n") (setq datum_line (car (entsel "\nSelect Datum Line:\n"))) ) (setq yval_datum_line (cadr (vlax-curve-getStartPoint datum_line)) yval_start_pline (- (cadr spt_pline) yval_datum_line) yval_end_pline (- (cadr ept_pline) yval_datum_line) ) (setq txt_position (getpoint "\nPick the lower-left corner of the box for elevation value:\n")) (setvar 'osmode 0) (setq datum_value (car (entsel "\nSelect Datum value:"))) (if (equal "MTEXT" (cdr (assoc 0 (entget datum_value)))) (setq datum_value (LM:UnFormat (cdr (assoc 1 (entget datum_value))) T)) (setq datum_value (cdr (assoc 1 (entget datum_value)))) ) (setq ang_spt_pline (angle (setq yval_position_one (list (car spt_pline) (+ (cadr txt_position) 0.1) (caddr txt_position))) spt_pline) ang_ept_pline (angle (setq yval_position_two (list (car ept_pline) (+ (cadr txt_position) 0.1) (caddr txt_position))) ept_pline) ) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 1 (rtos (+ yval_start_pline (atof datum_value)) 2 3)) (cons 10 yval_position_one) (cons 11 yval_position_one) (cons 40 0.35) (cons 72 0) (cons 73 2) (cons 50 ang_spt_pline))) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 1 (rtos (+ yval_end_pline (atof datum_value)) 2 3)) (cons 10 yval_position_two) (cons 11 yval_position_two) (cons 40 0.35) (cons 72 0) (cons 73 2) (cons 50 ang_ept_pline))) (princ "\nSelect intersecting lines:") (setq intersecting_lines (ssget (list (cons 0 "LINE") (cons 8 "DATUM-GRID"))) len (sslength intersecting_lines) i 0 ) (while (< i len) (setq int_pt_pline (vlax-safearray->list (vlax-variant-value (vla-IntersectWith (vlax-ename->vla-object pline) (vlax-ename->vla-object (ssname intersecting_lines i)) acExtendNone))) int_pt_datum_line (vlax-safearray->list (vlax-variant-value (vla-IntersectWith (vlax-ename->vla-object datum_line) (vlax-ename->vla-object (ssname intersecting_lines i)) acExtendNone))) dist (distance int_pt_pline int_pt_datum_line) yval_position (list (car int_pt_pline) (+ (cadr txt_position) 0.1) (caddr txt_position)) ang (angle yval_position int_pt_pline) i (1+ i) ) (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 1 (rtos (+ dist (atof datum_value)) 2 3)) (cons 10 yval_position) (cons 11 yval_position) (cons 40 0.35) (cons 72 0) (cons 73 2) (cons 50 ang_spt_pline))) ) (setvar 'osmode old_osmode) (prompt "\nAn elevation values were added!") (princ) ) ;;-------------------=={ UnFormat String }==------------------;; ;; ;; ;; Returns a string with all MText formatting codes removed. ;; ;;------------------------------------------------------------;; ;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; str - String to Process ;; ;; mtx - MText Flag (T if string is for use in MText) ;; ;;------------------------------------------------------------;; ;; Returns: String with formatting codes removed ;; ;;------------------------------------------------------------;; (defun LM:UnFormat ( str mtx / _replace rx ) (vl-load-com) (defun _replace ( new old str ) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new) ) (if (setq rx (vlax-get-or-create-object "VBScript.RegExp")) (progn (setq str (vl-catch-all-apply (function (lambda ( ) (vlax-put-property rx 'global actrue) (vlax-put-property rx 'multiline actrue) (vlax-put-property rx 'ignorecase acfalse) (foreach pair '( ("\032" . "\\\\\\\\") (" " . "\\\\P|\\n|\\t") ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]") ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);") ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}") ("$1" . "[\\\\]({)|{") ) (setq str (_replace (car pair) (cdr pair) str)) ) (if mtx (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str)) (_replace "\\" "\032" str) ) ) ) ) ) (vlax-release-object rx) (if (null (vl-catch-all-error-p str)) str ) ) ) ) The short video: YVAL.mp4 Best regards.

I have enjoyed the discussion of this thread. As I gave the task more thought and anaysis it became more clear that the task was not simple. As it appears that there is still no satisfacory solution I thought I would offer the following. The first goal for me was to create a function that would create a midline between two non parallel lines. The mid-lines extents should be a function of the given line segments. This function could then be used in a program that would step through the line segments of one of the polylines and search the other polyline for relevant segments. The function "midline" accepts four points. The first two points, A1 and A2, are the ends of one line sement while the thrid and fourth points, B1 and B2, are the ends of an opposing ilne segments. The diagram below details the variables in the function. The program uses vectors as I prefer them over angles which present, for me, a variety of problems. uA = unit vector in the diection from A1 to A2 uB = unit vector in the direction from B1 to B2 uBisector = unit vector in the direction of the angle bisector of uA and UB The ends of the two lines are projected onto the bisecting line defining 4 points, A1M, A2M, B1M, B2M. I debated which of the points to output for the line to be drawn. I first used the closest and furthest points from the intersecttion point ABIntr but I found it more helpful to use the two intermediate points (A1M and A2M in the example above). Here's an example of the results after manually steppng alone the polyline. Looking at the area circled in red we find: To fill the gap we need a curve that starts with a radius of 0.1514 and ends with a radius of 0.1693. This can be done with a spline or you may find it acceptable to extend the two lines to the point of intersection. The best way to create the spline is to use the Control Vertex Method and use the two endpoints and the imaginary point of intersecton for the middle CV. This ensures tangency to the two lines. As can be seen below the distance to a random point along the spline (red) agree! Run the program "test" and specify the end points of a line segment on one of the polylines, then the endpoints on a line segment on the opposing polyline. I have found the results very accurate and although it may not be used for creating the complete "hybrid " polyline it is helpful in finding the correct line for a specific segment.

I lost the post but found the answer, the question was how to keep a notepad window always on top of the CAD window. I did a google and found a Microsoft product. Admin please move if find other post. https://learn.microsoft.com/en-us/windows/powertoys/always-on-top You need to download and install then restart but works, tried with Bricscad.

Thought we were getting tolled when i saw @GP_ GIF had to double take on the original posted dwg.

Seneca said: “Homines dum docent discunt.” Which, roughly, means: Learn to explain and explain to learn

It will require more modification than just extending the bulge list - you also need to calculate the positions of the additional vertices. However, I really liked your suggestion (and it's also consistent with my existing Box Text program), and so I've updated the program to Version 1.3 to incorporate a new Filleted Rectangle textbox option (you may need to refresh the page to view the new version). Enjoy!

I guess you could do like (setq i (+ i 0.01)) 16 vertex poly would then create a 1600 vertex poly And then run overkill on the created polyline to remove all collinear vertexes.

Here's a proof-of-concept example for consideration - (defun update-attributes ( / bln idx ins map obj sel tag val ) (setq ;; List of ;; ((lower-left point) (upper-right point) "attribute value") map '( (( 0.0 0.0) (10.0 10.0) "abc") ((20.0 20.0) (30.0 30.0) "def") ) ;; Block name bln "YourBlock" tag "YourTag" ) (setq bln (strcase bln) tag (strcase tag) ) (if (setq sel (ssget "_X" (list '(0 . "INSERT") '(66 . 1) (cons 2 (strcat "`*U*," bln))))) (repeat (setq idx (sslength sel)) (setq idx (1- idx) obj (vlax-ename->vla-object (ssname sel idx)) ) (cond ( (/= bln (strcase (vlax-get-property obj (if (vlax-property-available-p obj 'effectivename) 'effectivename 'name))))) ( (setq ins (vlax-get obj 'insertionpoint) val (vl-some '(lambda ( itm ) (if (vl-every '<= (car itm) ins (cadr itm)) (caddr itm))) map) ) (vl-some '(lambda ( att ) (if (= tag (strcase (vla-get-tagstring att))) (progn (if (vlax-write-enabled-p att) (vla-put-textstring att val) ) t ) ) ) (vlax-invoke obj 'getattributes) ) ) ) ) ) ) (defun block-position-callback ( rtr arg ) (if (and arg (wcmatch (strcase (car arg) t) "qsave,save,saveas,plot,publish")) (update-attributes) ) (princ) ) ( (lambda ( key ) (vl-load-com) (foreach rtr (cdar (vlr-reactors :vlr-command-reactor)) (if (= key (vlr-data rtr)) (vlr-remove rtr) ) ) (vlr-set-notification (vlr-command-reactor key '( (:vlr-commandwillstart . block-position-callback) ) ) 'active-document-only ) (update-attributes) (princ) ) "block-position-reactor" ) There is no command to run the program: simply amend the block name, tag name, and map at the top of the code to suit your setup, and then load the program - the attributes will be automatically updated when the drawing is saved or plotted.

I did write something once to find and launch documents but its a little over the top probably. But Bigal also had a good suggestion , a program called everything.

@Steven P See what this does. again will use default browser. (startapp "explorer.exe" "https://www.youtube.com/watch?v=dQw4w9WgXcQ") So above can be (defun c:GetGoogle ( / Search Page) (setq Search (getstring "Enter Serch Term: [use '+' between terms] ")) ;; get search term, '+' between words (setq Page (strcat "https://www.google.com/search?q=" Search)) ;; google + search term address (startapp "explorer.exe" page) ) -edit didn't have the exe

actually quite nice Steven , think I'm gonna add this to one of my toolbars (if there's still room that is...) for opening things I also like : https://lee-mac.com/open.html

also shell commands - I've only used that once though: (defun c:GetGoogle ( / SearchTerm PageBase) (setq SearchTerm (getstring "Enter Serch Term: [use '+' between terms] ")) ;; get search term, '+' between words (setq PageBase "(command \"shell\" \"start microsoft-edge:http://google.com/search?q=") ;; google address (setq Page (strcat PageBase SearchTerm "\")" )) ;; google + search term address (eval (read Page)) ;; open 'Page' ) Guess what this does....

Even more reason to give weight to the opinions of those who have more experience in this area To the man with a hammer, everything looks like a nail.

I think it's time you started to learn AutoLISP @Nikon

Are you able to post a copy of the LISP so we can see what is happening? Sounds like your (command method is referring to the source file and the (vla- method is referring to your working file

Updated code here

A version also for closed polylines. Minimally tested... centerPline_v2.LSP

Since we're all going off topic (thanks a lot Bigal ) , might as well join the band. Added the 'check before paste' lisp to my toolbar. Not sure if I'm ever gonna use it but that wasn't the point, was working on a way to make it a little more easier for myself to update the toolbars for my colleagues (the old last century toolbars , you oldies know what I mean) so lazy as I am , created a button for that too. It hasn't been field tested though so it may or may not work at all... New for me was the help part. Never used html in my life before and also read-write stream only used a couple of times (to create a few .bmp files for the toolbar by means of lisp , look for the Party button) So lets party yeah! euh ...the button I mean (oh just press the darn help button) Easy_Toolbar_Creator.lsp

You can try if this works better. No dbx in this version Start app , make selection , select drawing you want to paste in later. This drawing is shortly opened (not sure if it works if drawing is already open) List with blocknames is created and drawing is closed. Blocknames are compared and if duplicates are found message is displayed. You can choose 1- Stop , 2 - Rename the blocks in drawing you made the selection set (not the other drawing), or 3 - copy / paste as it is. Only thing left to do is select your basepoint (or replace 'pause' with "0,0" in the code) and selection set is placed on clipboard , ready to paste. ;;; check before paste - rlx 2025-10-22 (defun c:cbp ( / this-dwg ss other-dwg blocknames-in-selectionset blocknames-in-other-dwg duplicate-blocknames dbx-doc) (setq this-dwg (vla-get-ActiveDocument (vlax-get-acad-object))) (if (and (setq ss (ssget)) (setq other-dwg (getfiled "Drawing to check before you paste" "" "dwg" 0))) (progn (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss))) (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset))) (if (vl-consp (setq blocknames-in-other-dwg (Get_EX_Blocknames other-dwg))) (setq blocknames-in-other-dwg (mapcar 'strcase blocknames-in-other-dwg))) (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-other-dwg)) (if (vl-consp duplicate-blocknames) (progn (dplm duplicate-blocknames "Duplicated block names : ") (setq inp (cfl (list "1 - I'm not gonna paste" "2 - Rename blocks before pasting" "3 - I'm gonna paste anyway"))) (cond ((or (void inp) (wcmatch inp "1*")) (alert "Copybase aborted")) ((wcmatch inp "2*")(foreach b duplicate-blocknames (rename_block_definition b)) (princ "\nBlocks are renamed - select your basepoint now") (command "_copybase" pause ss "")) ((wcmatch inp "3*") (princ "\nBlock names unchanged - select your basepoint now")(command "_copybase" pause ss "")) (t (princ"\nBite me...")) ) ) (progn (princ "\nNo duplicate block names found - select your basepoint")(command "_copybase" pause ss "")) ) ) ) (princ) ) ;;; get block names active doc - vanilla (defun _bl ( / b l ) (while (setq b (tblnext "BLOCK" (null b))) (if (zerop (boole 1 21 (cdr (assoc 70 b)))) (setq l (cons (cdr (assoc 2 b)) l)))) l) (defun Get_EX_Blocknames (other-dwg / fn l) (if (and (eq (type other-dwg) 'STR)(setq fn (findfile other-dwg)) (setq doc (vla-open (vla-get-documents (vlax-get-acad-object)) fn))) (progn (setq l (GetDocBlockNames doc))(vla-close doc)(vlax-release-object doc))) l) ;;; test (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object)))) (defun GetDocBlockNames ( d / b n l) (vlax-for b (vla-get-blocks d) (if (and (= :vlax-false (vla-get-isxref b)) (= :vlax-false (vla-get-islayout b)) (not (vl-string-search "*" (setq n (vla-get-name b)))))(setq l (cons n l)))) l) (defun create_unique_blockname ( $bn / i bn) (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn) (defun rename_block_definition ( $bn / bc bn ) (setq bc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))) (if (and (not (void $bn)) (tblsearch "block" $bn)) (vla-put-name (Collection-Member $bn bc)(setq bn (create_unique_blockname $bn)))) bn) (defun compare_block_names (a b / c) (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c) (defun Get_SS_BlockNames ( ss / n l) (foreach o (ss->ol ss)(if (and (setq n (block-n o))(not (member n l)))(setq l (cons n l)))) l) (defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x))))) (defun block-n (o)(if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference")) (if (vlax-property-available-p o 'EffectiveName) (vla-Get-EffectiveName o) (vla-Get-Name o)) nil)) (defun Collection-Member (m c / r) (if (vl-catch-all-error-p (setq r (vl-catch-all-apply 'vla-item (list c m)))) nil r)) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ;; choose from list (cfl '("1""2""3")) (defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p) (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d) (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)") (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)") (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil))) edit : just had an idea , why not open the 'to be pasted' drawing after you made your selection. Also tried if it was a bad thing if both drawings were already open and yes , that's bad... but then I'm a bad bad dragon (it still opens but as read only) Because I use vla-activate at the end , all lisp stops (obviously) Once drawings is activated you can copypaste / ctrl-V yourself (I'm sure as hell not comming to do that for you ) You decide what make you happy... ;;; check before paste 2 : after selection open the 'to be pasted' drawing - rlx 2025-10-22 (defun c:cbp2 ( / acDoc *docs* ss dbDoc blocknames-in-selectionset blocknames-in-dbDoc duplicate-blocknames inp do-it) (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)) *docs* (vla-get-documents (vlax-get-acad-object))) (if (and (setq ss (ssget)) (setq dbDoc (getfiled "Drawing to check before you paste" "" "dwg" 0))) (progn (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss))) (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset))) (if (vl-consp (setq blocknames-in-dbDoc (Get_EX_Blocknames dbDoc))) (setq blocknames-in-dbDoc (mapcar 'strcase blocknames-in-dbDoc))) (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-dbDoc)) (if (vl-consp duplicate-blocknames) (progn (dplm duplicate-blocknames "Duplicated block names : ") (setq inp (cfl (list "1 - I'm not gonna paste" "2 - Rename blocks before pasting" "3 - I'm gonna paste anyway"))) (cond ((or (void inp) (wcmatch inp "1*")) (alert "Copybase aborted")) ((wcmatch inp "2*")(foreach b duplicate-blocknames (rename_block_definition b)) (princ "\nBlocks are renamed - select your basepoint now") ;|(command "_copybase" pause ss "")|; (setq do-it t)) ((wcmatch inp "3*") (princ "\nBlock names unchanged - select your basepoint now") ;|(command "_copybase" pause ss "")|; (setq do-it t)) (t (princ"\nBite me...")) ) ) (progn (princ "\nNo duplicate block names found - select your basepoint") ;|(command "_copybase" pause ss "")|; (setq do-it t)) ) ) ) (if do-it (do_it)) ) (defun do_it ( / f d) (command "_copybase" pause ss "")(and (eq (type dbDoc) 'STR) (setq f (findfile dbDoc))(setq d (vla-open *docs* f)))(vla-activate d)) ;;; get block names active doc - vanilla (defun _bl ( / b l ) (while (setq b (tblnext "BLOCK" (null b))) (if (zerop (boole 1 21 (cdr (assoc 70 b)))) (setq l (cons (cdr (assoc 2 b)) l)))) l) (defun Get_EX_Blocknames (dbDoc / fn l) (if (and (eq (type dbDoc) 'STR)(setq fn (findfile dbDoc)) (setq doc (vla-open (vla-get-documents (vlax-get-acad-object)) fn))) (progn (setq l (GetDocBlockNames doc))(vla-close doc)(vlax-release-object doc))) l) ;;; test (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object)))) (defun GetDocBlockNames ( d / b n l) (vlax-for b (vla-get-blocks d) (if (and (= :vlax-false (vla-get-isxref b)) (= :vlax-false (vla-get-islayout b)) (not (vl-string-search "*" (setq n (vla-get-name b)))))(setq l (cons n l)))) l) (defun create_unique_blockname ( $bn / i bn) (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn) (defun rename_block_definition ( $bn / bc bn ) (setq bc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))) (if (and (not (void $bn)) (tblsearch "block" $bn)) (vla-put-name (Collection-Member $bn bc)(setq bn (create_unique_blockname $bn)))) bn) (defun compare_block_names (a b / c) (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c) (defun Get_SS_BlockNames ( ss / n l) (foreach o (ss->ol ss)(if (and (setq n (block-n o))(not (member n l)))(setq l (cons n l)))) l) (defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x))))) (defun block-n (o)(if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference")) (if (vlax-property-available-p o 'EffectiveName) (vla-Get-EffectiveName o) (vla-Get-Name o)) nil)) (defun Collection-Member (m c / r) (if (vl-catch-all-error-p (setq r (vl-catch-all-apply 'vla-item (list c m)))) nil r)) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ;; choose from list (cfl '("1""2""3")) (defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p) (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d) (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)") (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)") (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil)))

For completeness, the key here is the "Repeat" option of the -INSERT command - though, I'm unsure in which version this relatively new keyword was introduced.

If you need more information, check the documentation on the CMDACTIVE system variable.

It won't - it will continue indefinitely until the user presses Esc to force it to exit.

Select both polylines find the polyline that has the most vertex Then process those vertex with vlax-curve-getClosestPointTo store the mid point of vertex and closest point in a list entmake new polyline with list points. Seems to work well tho will need to test if you have open or closed polylines. defaults to closed tho i don't think its quite the mid / avg path this code isn't quite right see later post. ;;----------------------------------------------------------------------------;; ;; CLOSE POLY AVERAGE, Finds the mid point avg between close polylines donut shape (defun c:CLOSEPOLYAVG (/ sel1 sel2 ent1 ent2 cnt1 cnt2 main other i ptv ptc mid pts) (defun c:CPA () (C:CLOSEPOLYAVG)) (defun midpt (p1 p2) (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2) ) (setq sel1 (entsel "\nSelect First close Polyline: ")) (setq sel2 (entsel "\nSelect Second closed Polyline: ")) (if (and sel1 sel2) (progn (setq ent1 (vlax-ename->vla-object (car sel1)) ent2 (vlax-ename->vla-object (car sel2)) cnt1 (fix (vlax-curve-getEndParam ent1)) cnt2 (fix (vlax-curve-getEndParam ent2)) ) (if (> cnt1 cnt2) (setq main ent1 other ent2) (setq main ent2 other ent1) ) (setq pts '()) (setq i 0) (while (<= i (fix (vlax-curve-getEndParam main))) (setq ptv (vlax-curve-getPointAtParam main i)) (setq ptc (vlax-curve-getClosestPointTo other ptv)) (setq mid (midpt ptv ptc)) (setq pts (append pts (list mid))) (setq i (1+ i)) ) (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length pts)) '(70 . 1) ;; closed ) (mapcar '(lambda (p) (cons 10 p)) pts) ) ) (princ "\nNew midpoint polyline created.") ) (princ "\nSelection error.") ) (princ) )

Depending on your version of CAD, you can use this: (defun c:test ( ) (command "_.-insert" "yourblockname" "_s" 1 "_r" 0 "_re" "_y") (while (= 1 (logand 1 (getvar 'cmdactive))) (command "\\")) (princ) )

found this one under a layer of dust : ;;; https://lispbox.wordpress.com/2016/05/01/remove-any-unloaded-unreferenced-xrefsimagespdfsdgns-and-dwfs-in-a-one-click/ ;;; Remove any unloaded (unreferenced) XREFs,IMAGE's,PDF's,DGN's and DWF's in a one click ;;; Combined from existing subroutines by Igal Averbuh 2016 ;;; Based on https://www.theswamp.org/index.php?topic=51337.0 ;;; With respect to T.Willey ; Detach any unloaded (unreferenced) XREFs (defun C:dux () (vlax-for BIND_xrefname (vla-get-blocks (vla-get-ActiveDocument (vlax-get-Acad-object))) (if (= (vla-get-isxref BIND_xrefname) ':vlax-true) (progn (setq BIND_cont (entget (vlax-vla-object->ename BIND_xrefname)) BIND_cont (tblsearch "BLOCK" (cdr (assoc 2 BIND_cont))) ) (if (or (= (cdr (assoc 70 BIND_cont)) 4) (= (cdr (assoc 70 BIND_cont)) 12)) (vla-Detach BIND_xrefname) ) ) ) ) ) (defun c:RID ( / isDefReferenced dict data name tData lst imName ) ; Remove image definition of unreferenced and unloaded definitions. (defun isDefReferenced ( aEname / cnt data ) (setq cnt 0) (foreach i (entget aEname) (if (and (equal (car i) 330) (setq data (entget (cdr i))) (= (cdr (assoc 0 data)) "IMAGEDEF_REACTOR") ) (foreach j data (if (and (equal (car j) 330) (entget (cdr j))) (setq cnt (+ cnt 1)) ) ) ) ) (> cnt 0) ) ;------------------------------------------------------- (setq dict (namedobjdict)) (setq data (entget dict)) (setq name "ACAD_IMAGE_DICT") (if (setq data (dictsearch dict name)) (foreach i data (cond ((and imName (equal (car i) 350)) ;check to see if unreferenced or unload (setq tData (entget (cdr i))) (if (or (equal (cdr (assoc 280 tData)) 0) (not (isDefReferenced (cdr i)))) (setq lst (cons (cons imName (cdr i)) lst)) ) ) ((equal (car i) 3) (setq imName (cdr i))) (t (setq imName nil)) ) ) ) (if lst (progn (setq dict (cdr (assoc -1 data))) (foreach i lst (dictremove dict (car i)) (entdel (cdr i)) ) (prompt (strcat "\n Removed " (itoa (length lst)) " image definition(s).")) ) ) (princ) ) (defun c:RPD ( / isDefReferenced dict data name tData lst imName ) ; Remove pdf definition of unreferenced and unloaded definitions. (defun isDefReferenced ( aEname / cnt data ) (setq cnt 0) (foreach i (entget aEname) (if (and (equal (car i) 330) (setq data (entget (cdr i))) (= (cdr (assoc 0 data)) "IMAGEDEF_REACTOR") ) (foreach j data (if (and (equal (car j) 330) (entget (cdr j))) (setq cnt (+ cnt 1)) ) ) ) ) (> cnt 0) ) ;------------------------------------------------------- (setq dict (namedobjdict)) (setq data (entget dict)) (setq name "ACAD_PDFDEFINITIONS") (if (setq data (dictsearch dict name)) (foreach i data (cond ((and imName (equal (car i) 350)) ;check to see if unreferenced or unload (setq tData (entget (cdr i))) (if (or (equal (cdr (assoc 280 tData)) 0) (not (isDefReferenced (cdr i)))) (setq lst (cons (cons imName (cdr i)) lst)) ) ) ((equal (car i) 3) (setq imName (cdr i))) (t (setq imName nil)) ) ) ) (if lst (progn (setq dict (cdr (assoc -1 data))) (foreach i lst (dictremove dict (car i)) (entdel (cdr i)) ) (prompt (strcat "\n Removed " (itoa (length lst)) " pdf definition(s).")) ) ) (princ) ) (defun c:RDD ( / isDefReferenced dict data name tData lst imName ) ; Remove dgn definition of unreferenced and unloaded definitions. (defun isDefReferenced ( aEname / cnt data ) (setq cnt 0) (foreach i (entget aEname) (if (and (equal (car i) 330) (setq data (entget (cdr i))) (= (cdr (assoc 0 data)) "IMAGEDEF_REACTOR") ) (foreach j data (if (and (equal (car j) 330) (entget (cdr j))) (setq cnt (+ cnt 1)) ) ) ) ) (> cnt 0) ) ;------------------------------------------------------- (setq dict (namedobjdict)) (setq data (entget dict)) (setq name "ACAD_DGNDEFINITIONS") (if (setq data (dictsearch dict name)) (foreach i data (cond ((and imName (equal (car i) 350)) ;check to see if unreferenced or unload (setq tData (entget (cdr i))) (if (or (equal (cdr (assoc 280 tData)) 0) (not (isDefReferenced (cdr i)))) (setq lst (cons (cons imName (cdr i)) lst)) ) ) ((equal (car i) 3) (setq imName (cdr i))) (t (setq imName nil)) ) ) ) (if lst (progn (setq dict (cdr (assoc -1 data))) (foreach i lst (dictremove dict (car i)) (entdel (cdr i)) ) (prompt (strcat "\n Removed " (itoa (length lst)) " dgn definition(s).")) ) ) (princ) ) (defun c:RWD ( / isDefReferenced dict data name tData lst imName ) ; Remove dwf definition of unreferenced and unloaded definitions. (defun isDefReferenced ( aEname / cnt data ) (setq cnt 0) (foreach i (entget aEname) (if (and (equal (car i) 330) (setq data (entget (cdr i))) (= (cdr (assoc 0 data)) "IMAGEDEF_REACTOR") ) (foreach j data (if (and (equal (car j) 330) (entget (cdr j))) (setq cnt (+ cnt 1)) ) ) ) ) (> cnt 0) ) ;------------------------------------------------------- (setq dict (namedobjdict)) (setq data (entget dict)) (setq name "ACAD_DWFDEFINITIONS") (if (setq data (dictsearch dict name)) (foreach i data (cond ((and imName (equal (car i) 350)) ;check to see if unreferenced or unload (setq tData (entget (cdr i))) (if (or (equal (cdr (assoc 280 tData)) 0) (not (isDefReferenced (cdr i)))) (setq lst (cons (cons imName (cdr i)) lst)) ) ) ((equal (car i) 3) (setq imName (cdr i))) (t (setq imName nil)) ) ) ) (if lst (progn (setq dict (cdr (assoc -1 data))) (foreach i lst (dictremove dict (car i)) (entdel (cdr i)) ) (prompt (strcat "\n Removed " (itoa (length lst)) " dwf definition(s).")) ) ) (princ) ) (defun c:eid () (c:dux) (c:rid) (c:rpd) (c:rdd) (c:rwd) (vl-cmdf "_.externalreferences") (princ) ) (c:eid)

maybe something like this (untested) ;;; copy & paste for dummies - rlx 2025-10-18 (defun c:capfd ( / this-dwg ss other-dwg blocknames-in-selectionset blocknames-in-other-dwg duplicate-blocknames) (setq this-dwg (vla-get-ActiveDocument (vlax-get-acad-object))) (if (and (setq ss (ssget)) (setq other-dwg (getfiled "Copy SS to:" "" "dwg" 0))) (progn (setq blocknames-in-selectionset (Get_SS_BlockNames ss)) (setq blocknames-in-other-dwg (Get_DBX_Blocknames other-dwg)) (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-other-dwg)) (if (vl-consp duplicate-blocknames) (progn (dplm duplicate-blocknames "Duplicated block names : ") (if (yes_no "Copy anyway?") (ctd ss other-dwg) (princ"\nBite me...") ) ) (ctd ss other-dwg) ) ) ) (princ) ) (defun compare_block_names (a b / c) (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c) (defun Get_SS_BlockNames ( ss / n l) (foreach o (ss->ol ss) (if (and (block-p o)(not (member (setq n (block-n o)) l))) (setq l (cons n l)))) l) (defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) ; (block-p (vlax-ename->vla-object (car (entsel)))) (defun block-p (o) (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference"))) (defun block-n (o) (if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference")) (if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o)) nil)) ; (yes_no "Do you like snow") (defun yes_no ( $m / f p i r ) (and (= (type $m) 'STR) (setq f (vl-filename-mktemp ".dcl")) (setq p (open f "w")) (write-line (strcat "yesno:dialog{label=\"" $m "?\";ok_cancel;}") p) (progn (close p)(gc) t) (setq i (load_dialog f)) (new_dialog "yesno" i) (progn (action_tile "accept" "(done_dialog 1)")(action_tile "cancel" "(done_dialog 0)") (setq r (start_dialog))(unload_dialog i)(vl-file-delete f) t)(if (= r 1) t nil))) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ;;; copy to drawing (defun ctd ( ss dwg / ss->ol dbx_ver acApp acDoc dbx object-list object-safe-array) (defun SS->OL (ss / i l) (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun dbx_ver ( / v) (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))) (setq acApp (vlax-get-acad-object) acDoc (vla-get-ActiveDocument acApp)) (setq dbx (vl-catch-all-apply 'vla-getinterfaceobject (list acApp (dbx_ver)))) (vla-open dbx dwg) ; put all block objects in a list (setq object-list (ss->ol ss)) ; put list with objects in a safe array (setq object-safe-array (vlax-make-safearray vlax-vbobject (cons 0 (1- (length object-list))))) (vl-catch-all-apply 'vlax-safearray-fill (list object-safe-array object-list)) ; copy objects to dbx-drawing (vla-CopyObjects acDoc object-safe-array (vla-get-ModelSpace dbx)) (vl-catch-all-apply 'vla-saveas (list dbx dwg)) (vl-catch-all-apply 'vlax-release-object (list dbx)) (setq object-list nil object-safe-array nil) (princ) ) ; test : (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object)))) ; returns sorted list (uppercase) like : ("BLOCK_A" "BLOCK_B" ...) (defun GetDocBlockNames (d / o n l) (vlax-for o (vla-get-blocks d)(if (and (= :vlax-false (vla-get-isxref o))(= :vlax-false (vla-get-islayout o)) (snvalid (setq n (vla-get-name o)) 0))(setq l (cons (strcase n) l))))(if (vl-consp l)(acad_strlsort l))) (defun Get_DBX_Blocknames ( doc-name / lst v objectdbx-document) (cond ((not (eq (type doc-name) 'STR)) (princ (strcat "\nInvalid filename : " (vl-princ-to-string doc-name)))) ((not (findfile doc-name)) (princ (strcat "\nFile not found : " (vl-princ-to-string doc-name)))) (t (vlax-for doc (vla-get-Documents (vlax-get-acad-object)) (and (eq (strcase (vla-get-fullname doc)) (strcase doc-name))(setq objectdbx-document doc))) (cond ((eq (type objectdbx-document) 'VLA-OBJECT)) ((not (setq objectdbx-document (vlax-create-object (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))))) (princ "\nUnable to start object dbx")) ((vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list objectdbx-document doc-name))) (princ (strcat "\nOdbx error - unable to acces : " doc-name))) (t (setq lst (GetDocBlockNames objectdbx-document))) ) ) ) (vl-catch-all-apply 'vla-close (list objectdbx-document :vlax-False)) (if (and (= 'vla-object (type objectdbx-document))(not (vlax-object-released-p objectdbx-document))) (vlax-release-object objectdbx-document)) (if (vl-consp lst) (mapcar 'strcase lst)) ) and if you want the rename version : ;;; copy for lazy dummies - rlx 2025-10-18 (defun c:cfld ( / this-dwg ss other-dwg blocknames-in-selectionset blocknames-in-other-dwg duplicate-blocknames) (setq this-dwg (vla-get-ActiveDocument (vlax-get-acad-object))) (if (and (setq ss (ssget)) (setq other-dwg (getfiled "Copy SS to:" "" "dwg" 0))) (progn (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss))) (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset))) (if (vl-consp (setq blocknames-in-other-dwg (Get_DBX_Blocknames other-dwg))) (setq blocknames-in-other-dwg (mapcar 'strcase blocknames-in-other-dwg))) (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-other-dwg)) (if (vl-consp duplicate-blocknames) (progn (dplm duplicate-blocknames "Duplicated block names : ") ;;; (if (yes_no "Copy anyway?") (ctd ss other-dwg) (princ"\nBite me...") ) (if (yes_no "Rename duplicates?") (progn (foreach b duplicate-blocknames (rename_block_definition b)) (ctd ss other-dwg) ) (princ"\nBite me...") ) ) (ctd ss other-dwg) ) ) ) (princ) ) ; check if $member exists in (vla-) %collection (defun Collection-Member ( $member %collection / result) (if (vl-catch-all-error-p (setq result (vl-catch-all-apply 'vla-item (list %collection $member)))) nil result)) (defun create_unique_blockname ( $bn / i bn) (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn) (defun rename_block_definition ( $bn / bn ) (if (and (not (void $bn)) (tblsearch "block" $bn)) (vla-put-name (Collection-Member $bn (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object)))) (setq bn (create_unique_blockname $bn)))) bn) (defun compare_block_names (a b / c) (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c) (defun Get_SS_BlockNames ( ss / n l) (foreach o (ss->ol ss) (if (and (block-p o)(not (member (setq n (block-n o)) l))) (setq l (cons n l)))) l) (defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) ; (block-p (vlax-ename->vla-object (car (entsel)))) (defun block-p (o) (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference"))) (defun block-n (o) (if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference")) (if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o)) nil)) ; (yes_no "Do you like snow") (defun yes_no ( $m / f p i r ) (and (= (type $m) 'STR) (setq f (vl-filename-mktemp ".dcl")) (setq p (open f "w")) (write-line (strcat "yesno:dialog{label=\"" $m "?\";ok_cancel;}") p) (progn (close p)(gc) t) (setq i (load_dialog f)) (new_dialog "yesno" i) (progn (action_tile "accept" "(done_dialog 1)")(action_tile "cancel" "(done_dialog 0)") (setq r (start_dialog))(unload_dialog i)(vl-file-delete f) t)(if (= r 1) t nil))) ;;; display list (plus message) (defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l)))) (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";" "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb") (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f)))) ;;; copy to drawing (defun ctd ( ss dwg / ss->ol dbx_ver acApp acDoc dbx object-list object-safe-array) (defun SS->OL (ss / i l) (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun dbx_ver ( / v) (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))) (setq acApp (vlax-get-acad-object) acDoc (vla-get-ActiveDocument acApp)) (setq dbx (vl-catch-all-apply 'vla-getinterfaceobject (list acApp (dbx_ver)))) (vla-open dbx dwg) ; put all block objects in a list (setq object-list (ss->ol ss)) ; put list with objects in a safe array (setq object-safe-array (vlax-make-safearray vlax-vbobject (cons 0 (1- (length object-list))))) (vl-catch-all-apply 'vlax-safearray-fill (list object-safe-array object-list)) ; copy objects to dbx-drawing (vla-CopyObjects acDoc object-safe-array (vla-get-ModelSpace dbx)) (vl-catch-all-apply 'vla-saveas (list dbx dwg)) (vl-catch-all-apply 'vlax-release-object (list dbx)) (setq object-list nil object-safe-array nil) (princ) ) ; test : (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object)))) ; returns sorted list (uppercase) like : ("BLOCK_A" "BLOCK_B" ...) (defun GetDocBlockNames (d / o n l) (vlax-for o (vla-get-blocks d)(if (and (= :vlax-false (vla-get-isxref o))(= :vlax-false (vla-get-islayout o)) (snvalid (setq n (vla-get-name o)) 0))(setq l (cons (strcase n) l))))(if (vl-consp l)(acad_strlsort l))) (defun Get_DBX_Blocknames ( doc-name / lst v objectdbx-document) (cond ((not (eq (type doc-name) 'STR)) (princ (strcat "\nInvalid filename : " (vl-princ-to-string doc-name)))) ((not (findfile doc-name)) (princ (strcat "\nFile not found : " (vl-princ-to-string doc-name)))) (t (vlax-for doc (vla-get-Documents (vlax-get-acad-object)) (and (eq (strcase (vla-get-fullname doc)) (strcase doc-name))(setq objectdbx-document doc))) (cond ((eq (type objectdbx-document) 'VLA-OBJECT)) ((not (setq objectdbx-document (vlax-create-object (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))))) (princ "\nUnable to start object dbx")) ((vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list objectdbx-document doc-name))) (princ (strcat "\nOdbx error - unable to acces : " doc-name))) (t (setq lst (GetDocBlockNames objectdbx-document))) ) ) ) (vl-catch-all-apply 'vla-close (list objectdbx-document :vlax-False)) (if (and (= 'vla-object (type objectdbx-document))(not (vlax-object-released-p objectdbx-document))) (vlax-release-object objectdbx-document)) (if (vl-consp lst) (mapcar 'strcase lst)) ) (c:cfld)

I think this code should meet what you need. ;************************ G L A V C V S ************************* ;************************** F E C I T *************************** (defun c:subTexta (/ e n le vlae txu tx cj g? tg) (vl-catch-all-apply '(lambda () (while (or (/= (setq tx (getstring (strcat "\nType TEXT to add to DIMENSION (escape to EXIT) " (if tx (strcat "<" tx ">") "") ": "))) "") txu) (set (if (= tx "") 'tx 'txu) (if (= tx "") txu tx)) (setq n nil cj (ssget "_:L" '((0 . "*DIMENSION")))) (while (setq e (ssname cj (setq n (if n (1+ n) 0)))) (setq g? (/= (setq tg (vla-get-Textoverride (setq vlae (vlax-ename->vla-object e)))) "")) ;(vla-put-Textoverride vlae (if g? (strcat tg (if (wcmatch tg "*\\X*") "\n" "\\X") tx) (strcat tg "<>\\X" tx)));ACTIVA ESTA LÍNEA SI QUIERES EVITAR QUE PONGA EL SIGNO + DELANTE DEL PRIMER TEXTO Y DESACTIVA LA SIGUIENTE LÍNEA DE CODIGO (vla-put-Textoverride vlae (if g? (strcat (if (wcmatch tg "+*") "" "+") tg (if (wcmatch tg "*\\X*") "\n" "\\X") tx) (strcat "+" (rtos (vla-get-Measurement vlae) 2 (vla-get-PrimaryUnitsPrecision vlae)) "\\X" tx))) ) ) ) ) (princ) )

Another By @Lee Mac Area.lsp look on his web site. https://www.lee-mac.com/arealabel.html

Here are two good options from Lee Mac

Look for Notepad your Acad.pgp make code even shorter. This the bat file I use. d: cd\alan\lisp findstr %1 *.lsp

If you wish to entmake a field, you need to also entmake the FIELD entity within the TEXT entry of the ACAD_FIELD dictionary found within the extension dictionary attached to the entity - this is theoretically possible, but a lot of work and wheel reinvention. Instead, if you either create the MText object using vla-addmtext or convert the MTEXT entity into a VLA object and set the textstring property to a field expression, the CAD platform will automatically parse the field expression and configure the corresponding dictionaries for you.

I use Everything all the time it indexes hard drives and finds a file instantly. Re Access, Word, Excel and Libre office all of these can be accessed from CAD I use Bricscad. You can for say Access not only open but actually get at the data, most common being Excel get and put. If you have a few known files you want to open all the time can either make a defun for each and load on startup or my preferred would be a sub menu in a POP menu with the file names as the description. As mentioned already using notepad is shown how in ACAD.PGP as an already defined option.

Didn't have the exe in the startapp line so maybe thats why?

This will search a location for a file type, in the example searching for LISP files in c:\MyLocation\Here - remember to use a double backslash in any location, and return a list of files names + extensions (also folders if the file type is *.*). (setq myfiles (vl-directory-files "C:\\MyLocation\\Here" "*.lsp" nil)) You could do a search of this list to check if your required file is in there As MHUPP use startapp to open the file, here opens the file in variable Lispfile with notepad (startapp "notepad" Lispfile) MHUPP example was for explorer - I didn't know that method would work for any file type to open the default programme. For the first line here, your file path could be contained in a list, looping through each list item (location) until you find the file you want - could search a few locations if you knew them and want to hardcode them in the LISP, and if fails to find them there use MHUPPs 'getfiled' line for the user to select a folder or file. Use an if, cond or while loop to open the file where it finds it and stop the rest of the loop from looping

Had a command DIR to start in the folder of the active drawing would open the save prompt like window to allow you to select the file you want. pretty sure if you feed the path to explorer it will use the default program to open the file. (defun C:DIR ( / filePath) (setq dwgPath (getvar "DWGPREFIX")) (setq filePath (getfiled "Select a File to Open" dwgPath "*" 0)) ;limit what types you see by changing "*" (if filePath (progn (startapp "explorer.exe" filePath) (princ (strcat "\nOpening: " filePath)) ) (princ "\nNo file selected.") ) (princ) ) -edit You can also hard code where it stats in like if your documents are in a network drive. (setq filePath (getfiled "Select a Spec File" "C:\\Project\\spec\\" "PDF" 0)) ;look in spec folder for all pdf's

Oh I'm not mad, I just think you're blinkered into using the Startup Suite. As I've suggested throughout this thread, I would use the acaddoc.lsp. In my acaddoc.lsp, I have the following basic code: ( (lambda ( d ) (foreach x (vl-directory-files d "*.lsp" 1) (if (/= "acaddoc.lsp" (strcase x t)) (load (strcat d "\\" x) nil) ) ) ) "C:\\YourLISPFolder" ) Then, whatever .lsp files I place in "C:\\YourLISPFolder" are automatically loaded on startup - no need to change the Startup Suite, no need to modify the acaddoc.lsp any further - just drop a file into the folder.

@Nikon My 2c .. place all your lisp files in a subfolder under "MYDOCUMENTS". Then you don't have to worry about permissions, AutoCAD version or usernames. (strcat (getvar "MYDOCUMENTSPREFIX") "\\LISP") Then add this to your support paths and DONE!

You can enable VLIDE in newer releases by setting LISPSYS=0. https://help.autodesk.com/view/ACD/2024/ENU/?guid=GUID-1853092D-6E6D-4A06-8956-AD2C3DF203A3

I'm still not understanding why this won't do the trick. I've been successfully loading files for 20+ years using a version of that code and a custom MNL tied to a partial CUI. Adding a bunch of lisp routines to the startup suite is not standard practice ( well at least in my little world : ) )

I think Steven is right , this is about redefining or not. When you insert a block without path , AutoCad uses the block definition allready present in active drawing. If you put a path to it , AutoCad will overwrite current block definition with the one on file. So , if you insert block for the first time , then edit it and after that insert the one from file , your edited definition will be overwritten again. Standard / classic / basic AutoCad behaviour.

I agree with what you said. (setq theblock (vla-InsertBlock mspace ip item xscale yscale zscale rot)) Editing the code like this fixed it. Thanks .

O mine is the other way around in that the viewport has to be existing in paperspace already with the sacle you want. ;;----------------------------------------------------------------------------;; ;; Creates Viewport outline and moves it to Model space (defun C:VP2M (/ SS vp elist MiscOn cen c40 c41 LL UR) (if (setq SS (ssget "_X" (list '(0 . "viewport") (cons 410 (getvar 'ctab))))) (foreach vp (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) (setq elist (entget vp)) (if (> (cdr (assoc '69 elist)) 1) ; skip display viewport (progn (if (= (cdr (assoc '68 elist)) 0) ; is viewport active? (progn (setq MiscOn 'NO) (vl-cmdf "._Mview" "_on" "_si" vp) ; activate viewport ) (setq MiscOn 'YES) ) (setq cen (cdr (assoc '10 elist)) c40 (cdr (assoc '40 elist)) ;length c41 (cdr (assoc '41 elist)) ;width LL (list (- (car cen) (/ c40 2)) (- (cadr cen) (/ c41 2))) UR (list (+ (car cen) (/ c40 2)) (+ (cadr cen) (/ c41 2))) ) (vl-cmdf "_.Pspace") (vl-cmdf "_.Rectangle" LL UR) (vl-cmdf "_.Chspace" "_Last" "") (vl-cmdf "_.Pspace") (if (eq MiscOn 'NO) (vl-cmdf "_.Mview" "_off" "_si" vp) ; deactivate viewport ) ) ) ) ) ;(setvar 'Tilemode 1) ;switch to model space (princ) )

Like @mhupp I have a couple of make layouts I tend to use this front end which matches a user's title blocks. You can make multiple in one go using 2 different methods or pick a central point. It is two separate functions as you can check the rectangs 1st then make the layouts. Happy to discuss further.

After many months of avoiding this issue when I switched offices. I found out this happens when linetypes are created with .shp files required. If you have an issue where the linetyepes show incorrectly please just do the following to fix. 1. Type "OPTIONS" 2. Go to FILES tab 3. Support File folder, and navigate to the file that holds your fonts files and move it to the top of the list. 4. Finally, close cad and reopen. The hierarchy of the support files a crucial to what it loads and displays in cad. It will ignore the file needed if it is not prioritized in the support file folder correctly. You are welcome

Like @Lee Mac a simple change layouts script file. (command "Script" "myviews") (setvar 'ctab "D01") zoom e delay 500 (setvar 'ctab "D02") zoom e delay 500 (alert "All done")

Try the DELAY command - the argument represents a time in millisecs.

Yes I know. 'vlr-remove-all' is executed during loading so that any reactor created with the previous code is erased. It was a quick solution. Additionally, it runs when the drawing is exited or at startup before any other application loads, so it would only affect those reactors that should remain between drawings. I assumed that Nikon does not use these reactors. But it is probably a risky assumption. So I guess I am "obliged" to fix it. Below, a solution that keeps the reactors even if the drawing closure is canceled, that respects any reactor created by another application, and that regenerates them in each drawing. (defun fota (/ arch cad cmd mens etq letq n er lx) (defun pregunta (a b / cad) (cond ((member (strcase (car b)) '("CLOSE" "_CLOSE" "QUIT" "_QUIT" "EXIT" "_EXIT")) (if (and *lstCmds* (setq mens (cmdsCargados)) (= (vlax-invoke-method (vlax-create-object "wscript.shell") 'popup "Print commands on screen?" 0 "Save commands name" 4) 6) ) (progn (vla-AddMText (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point (getpoint "\nInsertion point...")) 100 mens) (vlax-invoke-method (vlax-get-acad-object) 'Update) ) ) ) ((= (type a) 'VLR-Lisp-Reactor) (if (not (member (setq cad (substr (car b) 4 (- (strlen (car b)) 4))) *lstCmds*)) (setq *lstCmds* (cons (substr (car b) 4 (- (strlen (car b)) 4)) *lstCmds*)) ) ) ) ) (setq letq '("Nikon1" "Nikon2") *afI* nil) (foreach r (vlr-reactors) (foreach er (cdr r) (if (member (setq etq (vlr-data er)) letq) (if (wcmatch etq "Nikon1,Nikon2") (setq lx (cons er lx)) ) ) ) ) (if lx (foreach r lx (vlr-remove r))) (foreach sim (atoms-family 0) (if (wcmatch (setq cmd (strcase (vl-princ-to-string sim) T)) "c:*") (setq *afI* (cons sim *afI*)) ) ) (setq *r* (vlr-command-reactor "Nikon1" '((:vlr-commandwillStart . pregunta)))) (setq *r1* (vlr-lisp-reactor "Nikon2" '((:vlr-lispwillstart . pregunta)))) ) (defun cmdsCargados (/ cad) (setq *cadCmds* nil) (foreach sim (atoms-family 0) (if (not (member sim *afI*)) (if (and (wcmatch (setq cad (strcase (vl-princ-to-string sim) T)) "c:*") (member (strcase (substr cad 3)) *lstCmds*) ) (setq *cadCmds* (strcat (if *cadCmds* (strcat *cadCmds* "\n") "\\C1Comandos utilizados durante la sesi贸n:\\C256\n") (substr cad 3))) ) ) ) *cadCmds* ) (fota)

Hi, With your drawing, this code will correct the polylines. To be adapted if used in another drawing (ssget filter) (vl-load-com) (defun c:Correct3DPL ( / ss AcDoc Space nb n ename obj l_pt lay new_obj) (setq ss (ssget "_X" '((0 . "POLYLINE") (67 . 0) (8 . "CTL_PNT") (66 . 1) (70 . 9)))) (cond (ss (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) nb 0 ) (repeat (setq n (sslength ss)) (setq ename (ssname ss (setq n (1- n))) obj (vlax-ename->vla-object ename) l_pt (vlax-get obj 'Coordinates) lay (vlax-get obj 'Layer) ) (cond ((eq (length l_pt) 12) (vla-delete obj) (setq new_obj (vlax-invoke Space 'Add3dPoly (cdddr l_pt))) (vla-put-Closed new_obj :vlax-true) (vla-put-Layer new_obj lay) (setq nb (1+ nb)) ) ) ) (princ (strcat "\n" (itoa nb) " polylines corrected.")) ) ) (prin1) )