Leaderboard

I don't really see the point of the dynamic mode in your function, especially if you want to snap to objects. This would seem to me to be sufficient and would resolve the osnap. (vl-load-com) (defun c:label_bearing ( / l_var AcDoc Space nw_style nw_obj pt1 pt alpha len_l m_pt val_txt) (setq l_var (mapcar 'getvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "TEXTSIZE"))) (initget "Bearing Degrees") (if (eq (getkword "\nResult in [Bearing/Degrees]?<Bearing>: ") "Degrees") (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS") (list 0 1 (* pi 1.5) 1 3 2 2)) (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS") (list 0 0 0 4 3 2 2)) ) (setvar "TEXTSIZE" (* (getvar "VIEWSIZE") 0.015)) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) ) (vla-startundomark AcDoc) (cond ((null (tblsearch "STYLE" "BEARING")) (setq nw_style (vla-add (vla-get-textstyles AcDoc) "BEARING")) (mapcar '(lambda (pr val) (vlax-put nw_style pr val) ) (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag) (list "romand.shx" 0.0 0.0 1.0 0.0) ) ) ) (setq nw_obj (vla-addMtext Space (vlax-3d-point '(0.0 0.0 0.0)) 0.0 "" ) ) (initget 1) (setq pt1 (getpoint "\nPick base point: ")) (initget 1) (setq pt (getpoint pt1 "\nPick other point: ")) (entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt))) (setq alpha (angle pt1 pt) len_l (distance pt1 pt) m_pt (mapcar '* (mapcar '+ pt1 pt) '(0.5 0.5 0.5)) val_txt (vl-string-subst "%%d" "d" (strcat (angtos alpha) "\\P " (rtos len_l) " m")) ) (if (and (> alpha (* pi 0.5)) (<= alpha (* pi 1.5))) (setq alpha (+ alpha pi)) ) (mapcar '(lambda (pr val) (vlax-put nw_obj pr val) ) (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'TextString 'Color) (list 5 (getvar "TEXTSIZE") 5 m_pt "BEARING" (getvar "CLAYER") alpha val_txt 2) ) (vla-endundomark AcDoc) (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "TEXTSIZE") l_var) (prin1) ) However, if you absolutely want the dynamic mode with the possibility of osnap, here is the redesigned function attached. ("osmode" must be defined beforehand, no possibility to force it when using the function) My management is succinct: only: "_end" "_mid" "_cen" "_nod" "_qua" "_int" "_ins" "_per" "_tan" "_nea" For a more elaborate management see perhaps the LeeMac function label_Bearing-vertex.lsp

A start with this? (vl-load-com) (defun c:label_bearing ( / l_var AcDoc Space nw_style nw_obj dxf_text pt1 pt2 dxf_line key pt alpha len_l m_pt val_txt) (setq l_var (mapcar 'getvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "TEXTSIZE"))) (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS") (list 0 1 (* pi 0.5) 4 3 2 2)) (setvar "TEXTSIZE" (* (getvar "VIEWSIZE") 0.015)) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) ) (vla-startundomark AcDoc) (cond ((null (tblsearch "STYLE" "BEARING")) (setq nw_style (vla-add (vla-get-textstyles AcDoc) "BEARING")) (mapcar '(lambda (pr val) (vlax-put nw_style pr val) ) (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag) (list "romand.shx" 0.0 0.0 1.0 0.0) ) ) ) (setq nw_obj (vla-addMtext Space (vlax-3d-point '(0.0 0.0 0.0)) 0.0 "" ) dxf_text (entget (entlast)) ) (initget 1) (setq pt1 (getpoint "\nPick base point: ") pt2 pt1 ) (entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt2))) (setq dxf_line (entget (entlast))) (while (equal pt2 pt1) (setq pt2 ((lambda ( / key pt alpha len_l m_pt) (princ "\nPick other point: ") (while (and (setq key (grread T 4 0)) (/= (car key) 3)) (cond ((eq (car key) 5) (redraw) (setq pt (cadr key) alpha (angle pt1 pt) len_l (distance pt1 pt) m_pt (mapcar '* (mapcar '+ pt1 pt) '(0.5 0.5 0.5)) val_txt (vl-string-subst "%%d" "d" (strcat (angtos alpha) "\\P " (rtos len_l) " m")) dxf_line (entmod (subst (cons 11 pt) (assoc 11 dxf_line) dxf_line ) ) ) (if (and (> alpha (* pi 0.5)) (<= alpha (* pi 1.5))) (setq alpha (+ alpha pi)) ) (mapcar '(lambda (pr val) (vlax-put nw_obj pr val) ) (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'TextString 'Color) (list 5 (getvar "TEXTSIZE") 5 m_pt "BEARING" (getvar "CLAYER") alpha val_txt 2) ) (entmod (subst (cons 50 alpha) (assoc 50 dxf_text) (subst (cons 10 (polar m_pt (+ alpha (* pi 0.5)) (getvar "TEXTSIZE"))) (assoc 10 dxf_text) dxf_txt) ) ) ) ) ) (cadr key) )) ) ) (vla-endundomark AcDoc) (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "TEXTSIZE") l_var) (prin1) )

I have a dump LISP called TakeADump, maybe I need this to go along with it!

I relied on your pictures... ??? In your picture: I see for degrees: Deg/Min/Sec - Clockwise (on) - South 90d0' If not correct change ANGDIR, ANGBASE and AUNITS in: (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS") (list 0 1 (* pi 1.5) 1 3 2 2))

Another example. This allows you to select a closed polyline and hatch it by aligning itself to the side of the selection point. (vl-load-com) (defun c:hatch_align_vtx ( / AcDoc flag *error* f_pat ent Space pr-1 pr-1 alpha hatch) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) flag T) (vla-StartUndoMark AcDoc) (defun *error* (msg) (and msg (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*")) (princ (strcat "\nError: " msg)) ) (if (= 8 (logand (getvar "UNDOCTL") 8)) (vla-endundomark AcDoc) ) (princ) ) (if (not (findfile "BAT_PUBL.pat")) (progn (setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\BAT_PUBL.pat") "w")) (write-line "*BAT_PUBL" f_pat) (write-line "45,0,0,0,.75" f_pat) (write-line "315,0,0,0,.75" f_pat) (close f_pat) ) ) (while (setq ent (entsel "\nSelect the long side polyline to hatch it: ")) (setq obj_curv (vlax-ename->vla-object (car ent))) (cond ((and (eq (vlax-get-property obj_curv 'ObjectName) "AcDbPolyline") (eq (vla-get-closed obj_curv) :vlax-true) ) (setq Space (if (eq (getvar "CVPORT") 1) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) pr-1 (fix (vlax-curve-getParamAtPoint obj_curv (vlax-curve-getClosestPointTo obj_curv (cadr ent) nil))) pr+1 (if (>= (1+ pr-1) (fix (vlax-curve-getEndParam obj_curv))) 0 (1+ pr-1)) alpha (+ (angle (vlax-curve-getPointAtParam obj_curv pr-1) (vlax-curve-getPointAtParam obj_curv pr+1)) (* 0.25 pi)) ) (setq hatch (vla-AddHatch Space acHatchPatternTypeCustomDefined "BAT_PUBL" :vlax-True)) (vlax-invoke hatch 'AppendOuterLoop (list obj_curv)) (vla-put-patternscale hatch 1.0) (vla-put-patternangle hatch alpha) (vla-evaluate hatch) ) ) ) (*error* nil) (vla-EndUndoMark AcDoc) (prin1) )

Select at start of what you need, then shift select the end is fastest I know (you can actually go from end to the beginning as well).

somehow a document type object lives along your copied_objects so try this : (defun c:new_desktop_file_copy ( / acad_dbx object_list zero_point db) (defun make_color_21 (/ layers) (setq layers (vla-get-layers acad_dbx)) (vlax-map-collection (vla-get-blocks acad_dbx) '(lambda (block) (vlax-map-collection block '(lambda (object) (vla-put-color object 256) (if (/= 21 (vla-get-color (setq layer (vla-item layers (vla-get-layer object))))) (vla-put-color layer 21)))) ) ) ) (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (strcat "ObjectDBX.AxDbDocument." (substr (getvar 'acadver) 1 2)))) (prompt "\nPick objects to copy to a new file on the desktop...") (setq object_list (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget)))))) (setq zero_point (getpoint "\nPick zero point for the copied entities: ")) (setq db (vla-get-database (vla-get-activedocument (vlax-get-acad-object)))) (foreach copied_object (setq odbx_objects_list (vlax-invoke db 'copyobjects object_list (vla-get-modelspace acad_dbx))) (if (vlax-method-applicable-p copied_object 'move) (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0)) (princ (strcat "\nUnable to move object name : " (vla-get-name copied_object))) ) ) (make_color_21) (vla-saveas acad_dbx (princ (strcat (getenv "userprofile") "\\Desktop\\" (getstring "\nEnter file name: ") ".dwg"))) (vlax-release-object acad_dbx) (princ) )

My first comment is when you hard print the pdf you have to pick a paper size so why would you not just pick a paper size to start with ? I do not understand the Custom scale size needed. In the world you are normally metric or imperial paper sizes. You can easily with a lisp etc plot a standard sheet size in a layout that has a Viewport at the correct scale. I think that is the step your not understanding, many example code does exist. For me a couple of choices make multiple layouts at scale walking along a pline, make multiple rectangs in Model at a scale matching viewports and title blocks in layouts. In this image select a title block and scale pick on Model and correct layout is made. A rectang is drawn in the model showing the result so you can accept or erase and run again. You can move and rotate the rectang before making the matching layout.

Must have deleted from my other post, But how grread works I don't know if you can use snaps. every time you move the mouse it updates the point and calculation. maybe Tsuky knows of a way.

The question was AutoCAD and was 12 years ago. To add, not much help just stating a program has a feature without any other context. Though there is the ability to adjust linetypes in MicroStation, the usual remedy is to break the line in most cases, same as AutoCAD.

Needs work, just an example from pyrx import Ap, Db, Ed, Ge, Gi import math print("command = yeehaw") class NavJig(Ed.DrawJig): def __init__(self, basepoint): Ed.DrawJig.__init__(self) self.ds = Ed.DragStatus.kNormal self.basepoint = basepoint self.curpoint = basepoint self.mt = Db.MText() self.mt.setDatabaseDefaults() self.mt.setAttachment(Db.MTextAttachmentPoint.kMiddleLeft) def get_vector_details(self, vector: Ge.Vector3d): v_length = vector.length() azimuth_rad = math.atan2(vector.x, vector.y) azimuth_deg = math.degrees(azimuth_rad) % 360 if 0 <= azimuth_deg <= 90: bearing = f"N {azimuth_deg:.2f} E" elif 90 < azimuth_deg <= 180: bearing = f"S {180 - azimuth_deg:.2f} E" elif 180 < azimuth_deg <= 270: bearing = f"S {azimuth_deg - 180:.2f} W" else: bearing = f"N {360 - azimuth_deg:.2f} W" return f"Length: {v_length:.4f}\\P" f"{azimuth_deg:.2f}%%d " f"{bearing}" def sampler(self): self.setUserInputControls(Ed.UserInputControls.kAccept3dCoordinates) self.ds, self.curpoint = self.acquirePoint() return self.ds def update(self): if self.ds == Ed.DragStatus.kNoChange: return False return True def worldDraw(self, wd: Gi.WorldDraw): if self.ds == Ed.DragStatus.kNoChange: return True try: geo = wd.geometry() v = self.curpoint - self.basepoint self.mt.setContents(self.get_vector_details(v)) self.mt.setLocation(self.basepoint + (v * 0.5)) self.mt.setDirection(v) geo.draw(self.mt) geo.polyline([self.basepoint, self.curpoint], Ge.Vector3d.kZAxis) return True except Exception as err: print(err) @Ap.Command() def yeehaw(): try: jig = NavJig(Ge.Point3d(0, 0, 0)) jig.setDispPrompt("\nPick point:\n") res = jig.drag() print("done", res) except Exception as err: print(err)

Have you looked into fields? When you edit a text object, you can type Ctrl-F to bring up the fields dialog. Pick a category, such as Date & Time, and pick the data you want to insert. To match your example, choose Date and a format. That field will be inserted into the text, like any other characters, but highlighted and with the corresponding data. There are many more pieces of data you can use. Once you put fields into your template, you may never have to change a title block again.

Hi, some years have passed but still thank you for the solution! I combined this lisp to another i had so now it sets everything inside the block to "ByBlock" Layer → 0 Color → ByBlock Linetype → ByBlock Lineweight → ByBlock Transparency → ByBlock Thanks again! (defun NestedPutProp (nme prop val / blk) (if (and (not (vl-catch-all-error-p (setq blk (vl-catch-all-apply 'vla-item (list (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)) ) nme ) ) ) ) ) (= :vlax-false (vla-get-islayout blk)) (= :vlax-false (vla-get-isxref blk)) ) (vlax-for obj blk (vlax-put obj prop val) ) ) ) (defun KGA_Conv_Pickset_To_ObjectList (ss / i ret) (if ss (repeat (setq i (sslength ss)) (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret ) ) ) ) ) (defun c:setbyblock ( / adoc ss doneLst) (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (if (setq ss (ssget '((0 . "INSERT")))) (foreach obj (KGA_Conv_Pickset_To_ObjectList ss) (if (not (vl-position (strcase (vla-get-name obj)) doneLst)) (progn ;; Set standard ByBlock properties (NestedPutProp (vla-get-name obj) 'Layer "0") (NestedPutProp (vla-get-name obj) 'Color 0) (NestedPutProp (vla-get-name obj) 'Linetype "BYBLOCK") (NestedPutProp (vla-get-name obj) 'Lineweight acLnWtByBlock) (NestedPutProp (vla-get-name obj) 'EntityTransparency "BYBLOCK") (setq doneLst (cons (strcase (vla-get-name obj)) doneLst)) ) ) ) ) (vla-regen adoc acallviewports) (vla-endundomark adoc) (princ) )

Please contact me when you reach here. I buy you durian.

Hi @karfung, Try this and see if it fits to your needs: ; ********************************************************************************************** ; Functions : PLMTXT ; Description : Add predefined text with length segment between two vertices on polyline ; Author : Saxlle ; Date : January 18, 2026 ; ********************************************************************************************** (prompt "\nTo run a LISP type: PLMTXT") (princ) (defun c:PLMTXT ( / old_osmode cur_layer old_nomutt height def_text ss len i dxf_70 plist dataList n k pt1 pt2 midPt ang dist npt pt lenSegment) (setq old_osmode (getvar 'osmode) cur_layer (getvar 'clayer) old_nomutt (getvar 'nomutt) height (getreal "\nEnter the text height <2.50>: ") ;; text height def_text "BD/1:200/" ;; default text ) (if (= height nil) (setq height 2.50) ;; defaul text height, it can be changed ) (setvar 'osmode 0) (if (not (tblsearch "LAYER" "SNA-TXT")) ;; check does layer 'SNA-TXT' exist or not (command-s "-layer" "m" "SNA-TXT" "") ;; make the SNA-TXT layer and set to be the current (command-s "-layer" "s" "SNA-TXT" "") ;; set the SNA-TXT layer to be the current ) (setvar 'nomutt 1) (princ "\nSelect POLYLINES:") (setq ss (ssget (list (cons 0 "LWPOLYLINE"))) len (sslength ss) plist (list) i 0 ) (setvar 'nomutt old_nomutt) (while (< i len) (setq dxf_70 (cdr (assoc 70 (entget (ssname ss i))))) (cond ;; the first cond ((= dxf_70 0) ;; LWPOLYLINE is OPEN (setq plist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (ssname ss i)))) dataList (list) n 0 k 1 ) (repeat (setq l (length plist)) (if (< k l) (setq pt1 (nth n plist) pt2 (nth k plist) midPt (mapcar '* (mapcar '+ pt1 pt2) (list 0.5 0.5)) ang (ang_check_text (angle pt1 pt2)) dist (distance pt1 pt2) npt (polar midPt (+ (angle pt1 pt2) (/ pi 2)) height) dataList (append (list (list npt ang dist)) dataList) n (1+ n) k (1+ k) ) ) ) (setq dataList (reverse dataList) n 0 ) (repeat (length dataList) (setq pt (car (nth n dataList)) ang (cadr (nth n dataList)) lenSegment (caddr (nth n dataList)) n (1+ n) ) (entmake (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 10 pt) (cons 11 pt) (cons 40 height) (cons 50 ang) (cons 71 5) (cons 1 (strcat def_text (rtos lenSegment 2 2) " m")))) ) ) ;; end first cond ;; the second cond ((= dxf_70 1) ;; LWPOLYLINE is CLOSED (setq plist (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (ssname ss i)))) dataList (list) n 0 k 1 ) (repeat (setq l (length plist)) (if (< k l) (setq pt1 (nth n plist) pt2 (nth k plist) midPt (mapcar '* (mapcar '+ pt1 pt2) (list 0.5 0.5)) ang (ang_check_text (angle pt1 pt2)) dist (distance pt1 pt2) npt (polar midPt (+ (angle pt1 pt2) (/ pi 2)) height) dataList (append (list (list npt ang dist)) dataList) n (1+ n) k (1+ k) ) (setq n 0 k (1- k) pt1 (nth k plist) pt2 (nth n plist) midPt (mapcar '* (mapcar '+ pt1 pt2) (list 0.5 0.5)) ang (ang_check_text (angle pt1 pt2)) dist (distance pt1 pt2) npt (polar midPt (+ (angle pt1 pt2) (/ pi 2)) height) dataList (append (list (list npt ang dist)) dataList) ) ) ) (setq dataList (reverse dataList) n 0 ) (repeat (length dataList) (setq pt (car (nth n dataList)) ang (cadr (nth n dataList)) lenSegment (caddr (nth n dataList)) n (1+ n) ) (entmake (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 10 pt) (cons 11 pt) (cons 40 height) (cons 50 ang) (cons 71 5) (cons 1 (strcat def_text (rtos lenSegment 2 2) " m")))) ) ) ;; end second cond ) ;; end cond (setq i (1+ i)) ) (setvar 'osmode old_osmode) ;; restore osmode (setvar 'clayer cur_layer) ;; restore old layer (prompt "\nThe text was inserted!") (princ) ) ;; Sub-function to get a proper text angle (defun ang_check_text (ang) (cond ((<= ang 1.57) (setq ang ang) ) ((and (>= ang 1.57) (<= ang 3.14)) (setq ang (+ ang pi)) ) ((and (>= ang 3.14) (<= ang 4.71)) (setq ang (- ang pi)) ) ((>= ang 4.71) (setq ang ang) ) ) ) Also, see the short video example of how it works. PLMTXT.mp4 Best regards.

just feed this to the vanilla monster : (ScriptDwg fn (list "LUNITS" "2" "INSUNITS" "4" "LUPREC" "6" ".zoom" "extents")) this part is all pretty basic AutoCad

;;; https://www.cadtutor.net/forum/topic/98937-repair-lisp-to-create-superimpose-acad/ (defun c:new_desktop_file_copy ( / acad_dbx object_list zero_point db odbx_objects_list ss fn db actDocs doc) (vl-load-com) (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (dbx_ver))) (defun make_color_21 ( / lays lay) (setq lays (vla-get-layers acad_dbx)) (vlax-map-collection (vla-get-blocks acad_dbx) '(lambda (b) (vlax-map-collection b '(lambda (o) (vla-put-color o 256) (if (/= 21 (vla-get-color (setq l (vla-item lays (vla-get-layer o))))) (vla-put-color l 21))))))) (prompt "\nPick objects to copy to a new file on the desktop...") (if (not (setq ss (ssget))) (princ "\nNothing was selected") (progn (setq object_list (ss->ol ss)) (setq zero_point (getpoint "\nPick zero point for the copied entities: ")) (setq db (vla-get-database (vla-get-activedocument (vlax-get-acad-object)))) (setq odbx_objects_list (vlax-invoke db 'copyobjects object_list (vla-get-modelspace acad_dbx))) (foreach copied_object odbx_objects_list (if (vlax-method-applicable-p copied_object 'move) (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0)) (princ (strcat "\nUnable to move object name : " (vla-get-name copied_object))) ) ) (make_color_21) (if (eq (setq fn (getstring "\nEnter file name: ")) "") (princ (strcat "\nInvalid filename for new drawing : " (vl-princ-to-string fn))) (progn (setq fn (strcat (getenv "userprofile") "\\Desktop\\" fn ".dwg")) (vla-saveas acad_dbx fn) (vlax-release-object acad_dbx) (gc) (gc) (foreach obj object_list (vla-delete obj)) (command ".qsave") ;|lets go vanilla|;(ScriptDwg fn (list "LUNITS" "2" "LUPREC" "6" ".zoom" "extents")) ) ) ) ) (princ) ) (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))))) (defun ScriptDwg ( dwg-fn dwg-com / scr-fn scr-fp ) (if (= (getvar "SDI") 1) (setvar "SDI" 0)) (setq scr-fn (strcat (getvar 'MYDOCUMENTSPREFIX) "\\ScriptDwg.scr")) (cond ((or (not (= (type dwg-fn) 'STR)) (not (findfile dwg-fn))) (princ (strcat "\n*error* : unable to find drawing : " (vl-princ-to-string dwg-fn)))) ((not (setq scr-fp (open scr-fn "w"))) (princ "\n*error* : unable to create script for commands.")) ((not (vl-consp dwg-com)) (princ "\n*error* : no commands in script")) (t (write-line (_open_cmd dwg-fn) scr-fp) (mapcar '(lambda (s)(write-line s scr-fp)) dwg-com) (write-line (_close_cmd) scr-fp) ) ) (if scr-fp (progn (close scr-fp)(gc)(command "._script" scr-fn))) ) (defun _open_cmd ($fn) (strcat ".open\n\"" $fn "\"\n(while (= 1 (logand (getvar \"cmdactive\") 1))(command \"Yes\"))")) (defun _close_cmd () (eval "(if (= (getvar \"writestat\") 1)(command \".qsave\" \".close\"))")) (defun c:t1 nil (c:new_desktop_file_copy))

Thank @pkenewell, I will study it.

@Nikon FWIW, Here is an opportunity to show you how to store and retrieve system variables without all the extra variables in Lisp. Also - I've added undo marks to the command so everything stays together, and some stuff into the error handler. Nothing you did wrong; just showing another way to do the same thing with different techniques. ; MHATCH VVA /2006 + additions /2026 (defun c:UShatch_Doub_200 ( / d lst nab vars *error*) (defun *error* (msg) (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*quit*,*exit*")) (princ (strcat "\nError: " msg "\n")) (princ "\nProgram Aborted.\n") ) ;; Cancel any open commands. (while (not (equal (getvar "cmdnames") ""))(command-s)) ;; If uh:varlist is found, reset all the system variables to original values stored. (if uh:varlist (mapcar '(lambda (var)(setvar (car var) (cdr var))) uh:varlist) ) (while (equal 8 (logand 8 (getvar "undoctl"))) (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object))) ) (princ) ) (vl-load-com) ;; Set an undo mark (vla-StartUndoMark (setq d (vla-get-activedocument (vlax-get-acad-object)))) ;;Create an association list for the system variables and values to be set. (setq vars '(("cmdecho" . 0) ("osmode" . 0) ("hpname" . "_USER") ("hpang" . 0) ("hpdouble" . 1) ("hpspace" . 200) ("hpassoc" . 1))) ;; Gather the existing values for the system variables and add to association list "uh:varlist" (setq uh:varlist (mapcar '(lambda (var)(cons (car var) (getvar (car var)))) vars) ) ;; Set all the system variable to the values stored in "vars". (mapcar '(lambda (var)(setvar (car var) (cdr var))) vars) (if (and (setq nab (ssget "_:L")) (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex nab)))) ) (foreach item lst (vl-catch-all-apply '(lambda ()(command "_.-bhatch" "_s" item "" "")) ) ) ) (mapcar (function (lambda (var)(setvar (car var) (cdr var)))) uh:varlist ) (vla-EndUndoMark d) (princ) ) (princ "Type in the command prompt UShatch_Doub_200")

If it all goes wrong then entmake it.... This link might help, with the code from code ding https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/entmake-hatch-with-base-point-or-object-polyline-entity-name/td-p/8696712

@karfung, why not to do a Writeblock command, it allow to set units as need, and show zoom extend new block.dwg

@devitg Ok, try this. Now labels are fields. If you prefer simply Mtext, Ithink that you can change it (with previous code) mult-label_bearing.lsp

@SLW210 how to select all the code at code tags , like a short key ctrl+a or whatever

Maybe use (setvar 'hpname "User") in code, sets the pattern name.

@karfung see the new dwg new block.dwg

@karfung it seem to be you need to make a new.dwg , if so, you can use WRITEBLOCK acad command .

maybe first do an audit on this drawing

Does the LISP file load the Visual LISP ActiveX functions with (vl-load-com)? I don't see it in the code.

@oliver Try to reload the code at this answer

Thanks, I've found that alternative an am using it for now. Functionally, I do prefer how the first addon works, but the resulting text issue is too painful to put up with because of that! I will submit a bug report to the developers.

This is one I was looking at yesterday, sharing here because I am really 12.... 'WipeBottom' will move the defined entity types to the Bottom or Top draw order in a selected block definition. Define the entity types and move direction in the code. Made up because I wanted to split out the selection part of the examples online and use the 2nd part via LISP without user interface. Via LISP I only wanted it to process a single block at a time - selection set processing can be from the calling LISP. Examples out there mostly from Lee Mac - see his website or the link in the code. But apart from that I really wanted to use the LISP command name. (defun c:WIPEBOTTOM ( / MyName MoveType MoveDirection) ;;AcDbTypes: AcDb + .... replace 'movetype' below with these as required ;;AcDbEntity, AcDbLine, AcDbCircle, AcDbArc, AcDbPolyline, AcDbText, AcDbMText ;;AcDbBlockReference, AcDbPoint, AcDbEllipse, AcDbSpline, AcDbHatch, AcDbTable ;;AcDbRasterImage, AcDbLeader, AcDbRay, AcDbXline, AcDbTrace, AcDbWipeout ;;AcDbDimension, AcDbAlignedDimension, AcDbRadialDimension, AcDbDiametricDimension ;;AcDb3PointAngularDimension, AcDbArcDimension, AcDbOrdinateDimension ;;MoveDirections: vla-movetobottom, vla-movetotop (Setq MyName (cdr (assoc 2 (entget (car(entsel "Select Block")))))) ;; block name (setq MoveType "AcDbHatch") (setq MoveDirection "vla-MoveToBottom") (WIPEBOTTOM MyName MoveType MoveDirection) (setq MoveType "AcDbWipeout") (setq MoveDirection "vla-MoveToBottom") (WIPEBOTTOM MyName MoveType MoveDirection) (setq MoveType "AcDbText") (setq MoveDirection "vla-MoveToTop") (WIPEBOTTOM MyName MoveType MoveDirection) ;; MyName: Real Block Name (example "MyBlock"), MoveType "ACDb....", MoveDirection "VLA-MoveTo..." (princ) ) (defun WIPEBOTTOM ( name MoveType MoveDirection / acblk acdoc obj name MoveType) ;;https://www.cadtutor.net/forum/topic/31462-wipeout-inside-blocks-issue/ ;;updated to single block selections only refer to link for selection sets ;Lee Mac 17.06.11 (defun LM:SortentsTable ( space / dict result ) (cond ((not (vl-catch-all-error-p (setq result (vl-catch-all-apply 'vla-item (list (setq dict (vla-GetExtensionDictionary space)) "ACAD_SORTENTS") ) ) ) ) result ) ; end not ( (vla-AddObject dict "ACAD_SORTENTS" "AcDbSortentsTable") ) ) ) ; end defun (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) ;;ACDoc reference (setq acblk (vla-get-blocks acdoc)) ;ACBlocks references (if name (progn ((lambda ( / lst ) (vlax-for obj (vla-item acblk name) ;;name: Block name. For each object in block (if (eq MoveType (vla-get-objectname obj)) ;;if object is required type (setq lst (cons obj lst)) ;; add to list ) ; end if ) ; end vlax-for (if lst (progn ( (eval (read MoveDirection)) ;; turn text move direction into command (LM:SortentsTable (vla-item acblk name)) ;; Sort objects - make into variable and only process once? (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst)))) lst )) ; end vlax-make-variant ) ; end vla-move (vla-regen acdoc acallviewports) ;; move to after lambda?? )) ; end if ; end progn )) ; end lambda ) ;; end progn ) ;; end if name )

to update entmod you need to get familiar with dxf codes. This simple lisps will dump to the command line. All entities follow a pattern. ;;----------------------------------------------------------------------------;; ;; Dump all DXF Group Data (defun C:DumpIt (/ ent) (while (setq ent (car (entsel "\nSelect Entity to Dump"))) (mapcar 'print (entget ent '( "*"))) ) (princ) ) ;;----------------------------------------------------------------------------;; ;; Dump All Visual Lisp Methods and Properties for Selected Entity (defun C:VDumpIt (/ ent) (while (setq ent (car (entsel "\nSelect Entity to Dump"))) (vlax-Dump-Object (vlax-Ename->Vla-Object ent) t) ) (princ) ) entsel will return an entity name and point of seleciton. use that to see which endpoint your closest to. and use that to update with entmod and entupd. ;;----------------------------------------------------------------------------;; ;; Extend line to new point. ;; https://www.cadtutor.net/forum/topic/98936-change-a-length-of-line-by-feeding-a-new-end-point-to-the-association-list/ (defun c:EXTLINE ( / sel ent pick line sp ep newpt) (if (setq sel (entsel "\nSelect line near the end to extend: ")) (progn (setq ent (car sel) pt (cadr sel) line (entget ent) ) (if (= (cdr (assoc 0 line)) "LINE") (progn (setq sp (cdr (assoc 10 line))) (setq ep (cdr (assoc 11 line))) (if (< (distance pt sp) (distance pt ep)) (setq newpt (getpoint ep "\nSpecify new endpoint: ") line (subst (cons 10 newpt) (assoc 10 line) line) ) (setq newpt (getpoint sp "\nSpecify new endpoint: ") line (subst (cons 11 newpt) (assoc 11 line) line) ) ) (entmod line) (entupd ent) ) (prompt "\nSelected entity is not a LINE.") ) ) ) (princ) )

You should use the Plot Stamp to add the plotted/printed date, the date on the drawing should always remain the same, each revision gets a date as well and also should remain the same throughout the history of the drawing.

I should have used acdbAngToS which honors AUNITS

Just a comment over at Autodesk forum I posted some code to plot all dwg's in a certain directory to one pdf using publish. It has a bug though if the dwg's do not have the correct page setup saved, they don't plot. It uses OBDX to make the page setup but that is the point where I have a problem, setting the pagesetup to a known saved name. Still working on it. Using a script may be easier for the moment as can plot the pdf for each dwg then use via lisp Ghostscript to join them back into one. The only downfall is the script will open every dwg to process. I have the code for layouts into one pdf so will look at using a script in that code. The post at Autodesk wants only Model space plotted. The pdf's are located in a \PDF directory under the current dwg directory.

Nice idea, here in Aus the brg is 0-360 dddmmss, much easier than the S & E etc. Maybe be second version.

BigAl loves his scripts and I suspect has one to copy and paste in here... though if you search this forum as well there are plenty of pdf and batch examples, just need to put them together. I have a PDF LISP (type in "plotPDF" and it creates a PDF in the drawings folder). Regardless what you are doing, typing 7 characters is a lot faster than the menu for PDF, select save folder and so on - so well worth finding one of these on the internet. As a side comment here set up a separate plotter for PDFs without the 'preview' check box - makes things better. The essence of the batch process is to create a script, saved as for example "MyScript.scr" (remember to set the file type to *.* so it saves right as a scr) Here is an example, copy, paste and change for each file you want to plot _.OPEN "YOUR_FILE_PATH_AND_FILE_NAME.dwg";;OPens the file (load "YOUR_PLOTTING_LISP_FILE_PATH_AND_FILE_NAME.lsp");;Loads the LISP (setvar "ctab" (nth 0 (layoutlist)));;Go to layout '0' (first layout in the layout list) (YOURPDFPLOTTINGLISP) (OR 'YOURPDFPLOTTINGLISP' );;do the plotting (if (= dbmod 0) (command ".close"));;if file not modified close (if (/= dbmod 0)(command ".close" "y"));;if file modified close and "OK to cancel changes" Then in a CAD file run the script We should one day find the time to make this nice, user friendly and a sticky thread the number of times this gets asked over the years... one day...

going to use grread and mouse pointer. maybe edit Demo2?

Thanks... I think I've narrowed it down to an addon downloaded from the Autodesk Exchange Apps site. As soon as I unload it, everything is back to normal. Looks like a minor bug in the addon. Thanks for all your suggestions!

Maybe with this subterfuge? (defun c:foo ( / src dxf app doc scr old new) (while (progn (setvar 'errno 0) (setq src (car (entsel (strcat "\nSelect block reference: ")))) (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)) new (strcat old (getstring t (strcat "\nSpecify new block name <" old ">: " (princ (strcat "\n" old))))) ) (cond ((and (= "" new) (or (not (snvalid new)) (tblsearch "block" new)) ) (princ "\nBlock name invalid or already exists.") ) (T (command "_.rename" "_block" old new)) ) ) ) (prin1) )

Use (list (entlast) p2) at place of p2: (list (entlast) p2) <=> at return of (entsel) (defun C:test1 ( / p1 p2 line1) (initget 1) (setq p1 (getpoint "\npick point1")) (initget 1) (setq p2 (getpoint p1 "\npick point2")) (command "_.line""_non" p1 "_non" p2 "") (setq line1 (entlast)) (command "_.lengthen" "_DYnamic" (list line1 p2) pause "") (command "_.change" line1 "" "_Properties" "_Color" "1" "") (prin1) )

Not so sure you can do 'end' with the keyboard with the standard (getstring) functions - either live with it or perhaps a DCL pop up might let you do this. Should be able to amend Lees Code to insert a dialogue if it really is necessary. Change this line to call another function with the code needed, return value will be the string that (setq new is looking for: (setq new (strcat (getstring t (strcat "\nPrefix For Block <" def ">: ")) " " old)))

Hehe reminds me of when I made a shortcut command for one of our customs lisp "Assembly populate".

I wasn't talking about the code

Ahh, was that yours RX? Mega apologies - I thought I had taken Lees from earlier in that thread (For this thread, RLX also had some ace code in the thread I linked to above)

Thanx Steven , for wiping mine...

This ? in dynamic mode... ((lambda ( / pt1 pt2 gap) (initget 1) (setq pt1 (getpoint "\nPick on 1st beam cl: ") pt2 pt1 gap 200 ) (while (equal pt2 pt1) (setq pt2 ((lambda ( / key pt alpha spane crnkL p1 p2) (princ "\nPick 2nd beam cl: ") (while (and (setq key (grread T 4 0)) (/= (car key) 3)) (cond ((eq (car key) 5) (redraw) (setq pt (cadr key)) (setq alpha (angle pt1 pt)) (setq spane (distance pt1 pt)) (setq crnkL (* 0.3 spane)) (cond ((and (>= alpha 0.0) (< alpha (* pi 0.5))) (setq p1 (polar pt (+ alpha ( * 0.5 pi)) gap) p2 (polar p1 (+ alpha pi) crnkL) ) ) ((and (>= alpha (* pi 0.5)) (< alpha pi)) (setq p1 (polar pt (+ alpha ( * 0.5 pi)) gap) p2 (polar p1 (+ alpha pi) crnkL) ) ) ((and (>= alpha pi) (< alpha (* 0.75 pi))) (setq p1 (polar pt (- alpha ( * 0.5 pi)) gap) p2 (polar p1 (+ alpha pi) crnkL) ) ) (T (setq p1 (polar pt (- alpha ( * 0.5 pi)) gap) p2 (polar p1 (+ alpha pi) crnkL) ) ) ) (grdraw pt1 pt 3) (grdraw p1 p2 1) ) ) ) (redraw) (cadr key) )) ) ) (prin1) ))

How about something like this, is that what you are looking for? (defun draw (pt1 pt2 len) (if (and pt1 pt2 len) (progn (entmakex (list '(0 . "LINE") (cons 10 pt1) (cons 11 (polar pt1 (angle pt1 pt2) len)) ) ) (entmakex (list '(0 . "LINE") (cons 10 (polar pt2 (angle pt2 pt1) len)) (cons 11 pt2) ) ) ) ) (princ) ) (draw (getpoint "\nFirst point: ") (getpoint "\nSecond point: ") (getdist "\nLine Length: ") )

I use a template with all my setups, then command "PSETUPIN" to import. If you want to use lisp to add one it's as simple as this: (vla-add (vla-get-PlotConfigurations (vla-get-ActiveDocument (vlax-get-acad-object)))"TEST") But then you also have to set the appropriate properties ... IMO it's much easier to use a template.