Leaderboard
Popular Content
Showing content with the highest reputation since 12/01/2025 in Posts
-
6 points
-
I don't believe I posted my Import multiple PDF pages as AutoCAD objects LISP. It does most of what I need, so I doubt if I'll spend any more time on it. ;;; Imports indicated page(s), converts to DWG entities, then arranges them spaced along +X. | ;;;-----------------------------------------------------------------------------------------------| ;;; ImPDF.lsp | ;;; | ;;; By SLW210 (a.k.a. Steve Wilson) | ;;; | ;;; Requires: AutoCAD 2024 + | ;;;-----------------------------------------------------------------------------------------------| (defun c:ImPDF (/ pdfPath pgStart pgEnd pg insPt gap doc ms layerColor bgColor layerName blk ) (vl-load-com) ;; Detect background color (setq bgColor (getvar "BACKGROUNDCOLOR")) ; 0=black, 7=white (setq layerColor (if (= bgColor 0) 7 0 ) ) ; white on black, black on white ;; Select PDF file (setq pdfPath (getfiled "Select PDF file to import" "" "pdf" 8)) (if (not pdfPath) (exit) ) ;; Page range (setq pgStart (getint "\nStart page <1>: ")) (if (not pgStart) (setq pgStart 1) ) (setq pgEnd (getint "\nEnd page <same>: ")) (if (not pgEnd) (setq pgEnd pgStart) ) ;; Starting insertion point (setq insPt (getpoint "\nInsertion point: ")) (if (not insPt) (setq insPt '(0 0 0)) ) ;; Gap between pages (setq gap (getreal "\nGap between pages <5.0>: ")) (if (not gap) (setq gap 5.0) ) ;; Get AutoCAD document (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ;; Set all entities inside block definition to layer + color (defun set-block-contents-color (blkRef layer color / blkDef) (setq blkDef (vla-item (vla-get-Blocks doc) (vla-get-Name blkRef))) (vlax-for ent blkDef (vl-catch-all-apply 'vla-put-layer (list ent layer)) (vl-catch-all-apply 'vla-put-color (list ent color)) ) ) ;; Loop through pages (setq pg pgStart) (while (<= pg pgEnd) (princ (strcat "\nImporting page " (itoa pg) "...")) ;; Attach PDF underlay (command "_-PDFATTACH" pdfPath (itoa pg) insPt 1.0 0.0) (setq u (entlast)) ;; underlay reference ;; Import to geometry (All, then detach) (command "_PDFIMPORT" u "All" "D") ;; The imported block reference is the last entity (setq blk (entlast)) (if blk (progn ;; Create layer for this page (setq layerName (strcat "PDF_Page_" (itoa pg))) (if (not (tblsearch "layer" layerName)) (vl-catch-all-apply 'vla-Add (list (vla-get-Layers doc) layerName) ) ) ;; Move block reference to layer (vl-catch-all-apply 'vla-put-layer (list (vlax-ename->vla-object blk) layerName) ) ;; Set nested geometry inside block (set-block-contents-color (vlax-ename->vla-object blk) layerName layerColor ) ;; Compute block width for next insertion point (setq minX 1e20 maxX -1e20 ) (vl-catch-all-apply 'vla-getboundingbox (list (vlax-ename->vla-object blk) 'pmin 'pmax) ) (setq pmin (vlax-safearray->list pmin)) (setq pmax (vlax-safearray->list pmax)) (setq width (- (car pmax) (car pmin))) (if (<= width 0.0) (setq width 100.0) ) ;; Update insertion point for next page (setq insPt (list (+ (car insPt) width gap) (cadr insPt) 0)) ) ) ;; Next page (setq pg (1+ pg)) ) (command "_ZOOM" "_E") (princ "\nAll pages imported successfully." ) (princ) ) With RLX's revision. ;;; Imports indicated page(s), converts to DWG entities, then arranges them spaced along +X. | ;;;-----------------------------------------------------------------------------------------------| ;;; ImPDF_0.2-RLX.lsp | ;;; | ;;; By SLW210 (a.k.a. Steve Wilson) | ;;; | ;;; Requires: AutoCAD 2017 + (for PDFIMPORT) | ;;; ;;; Revision by RLX ;;; ;;;-----------------------------------------------------------------------------------------------| (defun c:ImPDF (/ pdfPath pgStart pgEnd pg insPt gap doc ms layerColor bgColor layerName blk ) (vl-load-com) ;; Detect background color (setq bgColor (getvar "BACKGROUNDCOLOR")) ; 0=black, 7=white (setq layerColor (if (= bgColor 0) 7 0 ) ) ; white on black, black on white ;; Select PDF file (setq pdfPath (getfiled "Select PDF file to import" "" "pdf" 8)) (if (not pdfPath) (exit) ) ;; Page range (setq pgStart (getint "\nStart page <1>: ")) (if (not pgStart) (setq pgStart 1) ) (setq pgEnd (getint "\nEnd page <same>: ")) (if (not pgEnd) (setq pgEnd pgStart) ) ;; Starting insertion point (setq insPt (getpoint "\nInsertion point: ")) (if (not insPt) (setq insPt '(0 0 0)) ) ;; Gap between pages (setq gap (getreal "\nGap between pages <5.0>: ")) (if (not gap) (setq gap 5.0) ) ;; Get AutoCAD document (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) ;; Set all entities inside block definition to layer + color (defun set-block-contents-color (blkRef layer color / blkDef) (if (and blkRef (vlax-method-applicable-p blkRef 'Name)) (progn (setq blkDef (vla-item (vla-get-Blocks doc) (vla-get-Name blkRef))) (vlax-for ent blkDef (vl-catch-all-apply 'vla-put-layer (list ent layer)) (vl-catch-all-apply 'vla-put-color (list ent color)) ) ) ) ) ;; Loop through pages (setq pg pgStart) (while (<= pg pgEnd) (princ (strcat "\nImporting page " (itoa pg) "...")) ;; Attach PDF underlay (command "_-PDFATTACH" pdfPath (itoa pg) insPt 1.0 0.0) (setq u (entlast)) ;; underlay reference ;; Import to geometry (All, then detach) (command "_PDFIMPORT" u "All" "D") ;; The imported block reference is the last entity (setq blk (entlast)) (if blk (progn ;; Create layer for this page (setq layerName (strcat "PDF_Page_" (itoa pg))) (if (not (tblsearch "layer" layerName)) (vl-catch-all-apply 'vla-Add (list (vla-get-Layers doc) layerName) ) ) ;; Move block reference to layer (vl-catch-all-apply 'vla-put-layer (list (vlax-ename->vla-object blk) layerName) ) ;; Set nested geometry inside block (set-block-contents-color (vlax-ename->vla-object blk) layerName layerColor ) ;; Compute block width for next insertion point (setq minX 1e20 maxX -1e20 ) (vl-catch-all-apply 'vla-getboundingbox (list (vlax-ename->vla-object blk) 'pmin 'pmax) ) (setq pmin (vlax-safearray->list pmin)) (setq pmax (vlax-safearray->list pmax)) (setq width (- (car pmax) (car pmin))) (if (<= width 0.0) (setq width 100.0) ) ;; Update insertion point for next page (setq insPt (list (+ (car insPt) width gap) (cadr insPt) 0)) ) ) ;; Next page (setq pg (1+ pg)) ) (command "_ZOOM" "_E") (princ "\nAll pages imported successfully." ) (princ) )3 points
-
I did some more tests today and found that when the end segments were parallel, they didn't get added to the line. So I added support for that. This one was easy because the _cornerOffset function already checks for parallel segments and I just had to add a flag to inform the offset loop. And I found another example which it has a hard time on with concentric arcs, attached below. But that will be for another day since I have no more time for that this week. AxisExple3.dxf3 points
-
3 points
-
Nice test @PGia, thanks! For some reason I didnt consider closed polylines in the _checkOffset function, so I added an extra check there. Should work as expected now: Not sure about the short corner. The lines are so narrow the centerline is pushed back out of the point. Seems to be logical to me but it does feel intuitive. Narrow indents don't get much love from the centerline. So "inlets" don't have enough influence on the shape of the line. What would the expected result be? Below makes sense since there is not enough space to go into the indent. Or are you maybe something like this where the line splits and goes into the hole:3 points
-
@PGia Thanks for the encouragement and checking the results. I measure from the vertices instead of the lines. Those are calculated and the lines are just to connect the points. So perpendicular to the middle of segments of the centerline will always be a bit off, but if you measure from the vertices it should be centered correctly. Just like @GP_ said. I kept going in the same direction and I have made some improvements and got rid of some bugginess: The centerline should be a little more accurate now because of extra measurements (blue line) Crossing polylines get sharp corners on negative side Corner checks are done on all intersections of temporary line now (red line) More error checking so it doesn't crash on some of the example lines I left all of the 'animation' code commented out so you can give it a try ;| ; Calculate centerline between two polylines - dexus ; Function checks intersections of the offsets of two lines to create a middle/avarage line. ; https://www.cadtutor.net/forum/topic/98778-hybrid-parallel/page/6/#findComment-677339 ; Version 0.1 - Initial release 19-11-2025 ; Version 0.2 - Added corner support on negative side of crossing polylines 27-11-2025 ; Version 0.3 - Extra check using vertex to closest point as distance 28-11-2025 ; Version 0.4 - Added error function 28-11-2025 ; Version 0.5 - Improved distance check to prevent zigzag lines 01-12-2025 ; Version 0.6 - Check if offset can be used before adding points 01-12-2025 ; Version 0.7 - Improved side check on 3 points 01-12-2025 ; Version 0.8 - Don't compare startpoint to offset when eiter of the polylines is closed 04-12-2025 ; Version 0.9 - Add points for parallel end segments and set offsetgaptype 05-12-2025 |; (defun c:cpl (/ corners ent1 ent2 enx2 flipped gap loop maxlen offset offsetdistance parallel pts sides ss start te0 te1 te2 LM:ProjectPointToLine LM:intersections _addPoints _avarageAngle _checkOffset _cornerOffset _doOffset _getAnglesAtParam _getLength _polyline _rlw _side _wait *error*) (defun *error* (st) (if (wcmatch (strcase st t) "*break,*cancel*,*exit*") (redraw) (progn (vl-bt) (princ (strcat "\nOops! Something went wrong: ") st) ) ) (if (and te0 (not (vlax-erased-p te0))) (entdel te0)) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) (princ) ) ;| ; Draw Polyline - dexus ; Draw a polyline from a list of points, but filter out colinear points ; @Param lst list of points ; @Returns ename of polyline |; (defun _polyline (lst closed / prev pts) (while lst (cond ( (and (cdr lst) prev (or (equal (cdr lst) prev 1e-8) ; Remove duplicate points (null (inters prev (car lst) prev (cadr lst))) ; Remove collineair points ) ) ) ((setq pts (cons (cons 10 (setq prev (car lst))) pts))) ) (setq lst (cdr lst)) ) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length pts)) (cons 8 (getvar 'clayer)) (cons 70 (if closed 1 0)) ) (reverse pts) ) ) ) (defun _side (pline pnt / cpt end target der) ; https://www.theswamp.org/index.php?topic=55685.msg610429#msg610429 (setq cpt (vlax-curve-getClosestPointTo pline pnt) end (vlax-curve-getEndParam pline) target (vlax-curve-getParamAtPoint pline cpt) der (if (and (equal target (fix target) 1e-8) (or (vlax-curve-isClosed pline) (and (not (equal (vlax-curve-getStartParam pline) target 1e-8)) (not (equal end target 1e-8))) ) ) (mapcar '- (polar cpt (angle '(0 0) (vlax-curve-getFirstDeriv pline (rem (+ target 1e-3) end))) 1.0) (polar cpt (angle (vlax-curve-getFirstDeriv pline (rem (+ (- target 1e-3) end) end)) '(0 0)) 1.0) ) (vlax-curve-getFirstDeriv pline target) ) ) (minusp (sin (- (angle cpt pnt) (angle '(0.0 0.0) der)))) ) ;; Intersections - Lee Mac ;; mod - [int] acextendoption enum of intersectwith method (defun LM:intersections ( ob1 ob2 mod / lst rtn ) (if (and (vlax-method-applicable-p ob1 'intersectwith) (vlax-method-applicable-p ob2 'intersectwith) (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)) ) (repeat (/ (length lst) 3) (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn) lst (cdddr lst)) ) ) (reverse rtn) ) (defun _getLength (ent) (- (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) (vlax-curve-getDistAtParam ent (vlax-curve-getStartParam ent)) ) ) (defun _wait (msec) (not ( (lambda (start) (while (< (- (getvar 'millisecs) start) msec)) ) (getvar 'millisecs) ) ) ) (defun _addPoints (lst ent1 ent2 pts / len1 len2) (setq len1 (_getLength ent1) len2 (_getLength ent2) lst (vl-remove nil (mapcar (function (lambda (pt / d1 d2) (if (and (setq d1 (vlax-curve-getDistAtPoint ent1 pt)) (setq d2 (vlax-curve-getDistAtPoint ent2 pt)) ) (list (cond ((and (vlax-curve-isclosed ent1) (not (vlax-curve-isclosed ent2))) (/ d2 len2)) ((vlax-curve-isclosed ent2) (/ d1 len1)) ((+ (/ d1 len1) (/ d2 len2))) ) pt ) ) )) lst ) ) pts (append lst pts)) ; Animation ; (setq pts (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) ; (redraw) ; (foreach pt lst ; (tmpPoint (cadr pt) 1 1) ; ) ; ( ; (lambda (lst) ; (while (cadr lst) ; (grdraw (cadar lst) (cadar (setq lst (cdr lst))) 3) ; ) ; ) ; pts ; ) ; (vla-update ent1) ; (_wait 40) ; End animation pts ) (defun _checkOffset (ent1 ent2 offset) (or (vlax-curve-isclosed ent1) (vlax-curve-isclosed ent2) (and (equal (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getStartPoint ent2)) offset 1e-4) (equal (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) offset 1e-4) ) ) ) (defun _doOffset (offset / lst rtn) ; Global vars: pts ent1 ent2 sides te1 te2 (setq te1 nil) (setq te2 nil) (setq rtn (cond ((equal offset 0.0 1e-8) (if (setq lst (LM:intersections ent1 ent2 acExtendNone)) (setq pts (_addPoints lst ent1 ent2 pts)) ) lst ) ( (or ; Make offset (vl-catch-all-error-p (setq te1 (vl-catch-all-apply 'vlax-invoke (list ent1 'Offset (if (car sides) offset (- offset)))))) (cdr te1) (vl-catch-all-error-p (setq te2 (vl-catch-all-apply 'vlax-invoke (list ent2 'Offset (if (cadr sides) offset (- offset)))))) (cdr te2) (not (_checkOffset ent1 (car te1) offset)) (not (_checkOffset ent2 (car te2) offset)) (vla-put-visible (car te1) :vlax-false) (vla-put-visible (car te2) :vlax-false) ) (princ "\nOffset failed. ") nil ) ((setq lst (LM:intersections (car te1) (car te2) acExtendNone)) (if parallel ; Add points of parallel end segments (mapcar (function (lambda (ent1 ent2) (mapcar (function (lambda (pt) (if (equal pt (vlax-curve-getClosestPointTo ent2 pt) 1e-10) (setq lst (cons pt lst)) ) )) (list (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent1) ) ) )) (list (car te1) (car te2)) (list (car te2) (car te1)) ) ) (setq pts (_addPoints lst (car te1) (car te2) pts)) lst ) ) ) (if (and te1 (not (vl-catch-all-error-p te1))) (mapcar 'vla-delete te1)) (if (and te2 (not (vl-catch-all-error-p te2))) (mapcar 'vla-delete te2)) rtn ) ;| ; Project Point onto Line - Lee Mac ; @Param pt point to project ; @Param p1 first point of line ; @Param p2 second point of line ; @Returns projected point |; (defun LM:ProjectPointToLine ( pt p1 p2 / nm ) (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm)) (trans (list (car p1) (cadr p1) (caddr pt)) nm 0) ) (defun _getAnglesAtParam (ent pa / ang1 ang2) (if (and (vlax-curve-isClosed ent) (= pa 0)) ; Special case for closed Polyline (setq ang1 (vlax-curve-getFirstDeriv ent 1e-14) ang2 (vlax-curve-getFirstDeriv ent (- (fix (vlax-curve-getEndParam ent)) 1e-14))) (setq ang1 (vlax-curve-getFirstDeriv ent (+ pa 1e-14)) ang2 (vlax-curve-getFirstDeriv ent (- pa 1e-14))) ) (if (and ang1 ang2) (list (angle '(0 0 0) ang1) (angle '(0 0 0) ang2) ) ) ) ;| ; Avarage Angle - dexus ; Get angle of a line between two angles ; @Param ang1 real - Angle in radians ; @Param ang2 real - Angle in radians ; @Returns real - Angle in radians |; (defun _avarageAngle (ang1 ang2) (if (< (rem (+ ang1 pi) (+ pi pi)) (rem (+ ang2 pi) (+ pi pi)) ) (+ (* (- ang2 ang1) 0.5) ang1) (+ (* (- ang1 ang2) 0.5) ang2) ) ) ;| ; Calculate exact offset distance on a corner - dexus ; pt1 - Point on corner ; pt2 - Point on other side ; pt3 - Center for bisector ; pt4 - Target for corner of the offset ; pt5 - Find perpendicular point for offset distance ; / ; / ; -------- pt1 pt5 ; \ / ; pt4 ; \ ; ---- pt3 ----- pt2 ----- ; ; @Param ent1 Line to check corners ; @Param ent2 Opposing line ; @Returns List of offset distances (pt1 -> pt5) to calculate |; (defun _cornerOffset (ent1 ent2 / ang1 ang1a ang2 ang3 index pt1 pt2 pt3 pt4 pt5 rtn) (setq index 0) (repeat (fix (vlax-curve-getEndParam ent1)) (and (setq pt1 (vlax-curve-getPointAtParam ent1 index)) ; Point on corner (setq ang1 (_getAnglesAtParam ent1 index)) ; Angles of pt1 (setq ang1a (_avarageAngle (car ang1) (cadr ang1))) (setq te0 (entmakex (list (cons 0 "line") (cons 10 pt1) (cons 11 (polar pt1 (- ang1a halfPi) 1))))) ; Temp line for finding the angle on the other side (foreach pt2 (LM:intersections (vlax-ename->vla-object te0) ent2 acExtendThisEntity) ; Point on other side (and (setq ang2 (_getAnglesAtParam ent2 (vlax-curve-getParamAtPoint ent2 pt2))) ; Angle of pt2 (if (equal (rem (car ang1) pi) (rem (car ang2) pi) 1e-8) ; Is parallel? (and (setq parallel (or parallel (< index 1) (<= (fix (vlax-curve-getEndParam ent1)) (1+ index)) t)) (setq pt3 (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt1 pt2)) ; Midpoint (setq ang3 (car ang1)) ; Same angle als ang1 ) (and (setq pt3 (inters pt1 (polar pt1 (car ang1) 1) pt2 (polar pt2 (car ang2) 1) nil)) ; Find center for bisector (setq ang3 (_avarageAngle (angle pt1 pt3) (angle pt2 pt3))) ; Angle of bisector ) ) (setq pt4 (inters pt3 (polar pt3 ang3 1) pt1 (polar pt1 (+ ang1a halfPi) 1) nil)) ; Find target for corner of the offset (setq pt5 (LM:ProjectPointToLine pt4 pt1 (polar pt1 (+ (car ang1) halfPi) maxlen))) ; Find perpendicular point for offset distance (setq rtn (cons (distance pt1 pt5) rtn)) ; Return offset distance ; Animation ; (progn ; (redraw) ; (grdraw pt1 pt2 1) ; (grdraw pt4 pt5 2) ; (grdraw pt1 pt5 2) ; (grdraw pt2 pt5 2) ; (vla-update ent1) ; (_wait 120) ; ) ; End Animation ) ) ) (if (and te0 (not (vlax-erased-p te0))) (entdel te0)) (setq index (1+ index)) ) rtn ) (defun _rlw (lw / x1 x2 x3 x4 x5 x6) (if (and lw (= (cdr (assoc 0 lw)) "LWPOLYLINE")) (progn (foreach a1 lw (cond ((= (car a1) 10) (setq x2 (cons a1 x2))) ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4))) ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3))) ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5))) ((= (car a1) 210) (setq x6 (cons a1 x6))) (t (setq x1 (cons a1 x1))) ) ) (append (reverse x1) (append (apply (function append) (apply (function mapcar) (cons 'list (list x2 (cdr (reverse (cons (car x3) (reverse x3)))) (cdr (reverse (cons (car x4) (reverse x4)))) (cdr (reverse (cons (car x5) (reverse x5)))) )) )) x6) ) ) ) ) (if (and (not (while (cond ((not (setq ss (ssget '((0 . "LWPOLYLINE"))))) (princ "\nNothing selected. Try again...\n") ) ((/= (sslength ss) 2) (princ "\nSelect 2 polylines! Try again...\n") ) ((and (setq ent1 (ssname ss 0)) (setq ent2 (ssname ss 1)) (setq enx2 (entget ent2)) (setq ent1 (vlax-ename->vla-object ent1)) (setq ent2 (vlax-ename->vla-object ent2)) ) nil ; Stop loop ) ) ) ) ent1 ent2 ) (progn (and (< (distance (vlax-curve-getStartPoint ent1) (vlax-curve-getEndPoint ent2)) (distance (vlax-curve-getEndPoint ent1) (vlax-curve-getEndPoint ent2)) ) (setq flipped t) (entmod (_rlw enx2)) ) (setq sides (mapcar (function (lambda (a b / s m e) (setq s (_side a (vlax-curve-getStartPoint b)) m (_side a (vlax-curve-getPointAtParam b (* 0.5 (vlax-curve-getEndParam b)))) e (_side a (vlax-curve-getEndPoint b))) (or (and s m) (and s e) (and m e)) )) (list ent1 ent2) (list ent2 ent1) ) ) (if (not (numberp halfPi)) (setq halfPi (* pi 0.5))) (setq maxlen (* 1.1 (max (_getLength ent1) (_getLength ent2) ( (lambda (ent1 ent2 / step de1 div p_step dis dmax) (setq step (/ (setq de1 (vlax-curve-getDistAtParam ent1 (vlax-curve-getEndParam ent1))) 500) div step dmax 0.00) (while (< div de1) (setq p_step (vlax-curve-getPointAtDist ent1 div) dis (distance p_step (vlax-curve-getClosestPointTo ent2 p_step))) (if (> dis dmax) (setq dmax dis)) (setq div (+ div step)) ) dmax ) ent1 ent2 ) ) ) ) (mapcar ; Add half distances from closest point to every vertex (function (lambda (ent1 ent2 / index pt) (setq index 0) (repeat (fix (vlax-curve-getEndParam ent1)) (setq pt (vlax-curve-getPointAtParam ent1 index) corners (cons (* (distance pt (vlax-curve-getClosestPointTo ent2 pt)) 0.5) corners) index (1+ index)) ; Animation ; (redraw) ; (grdraw pt (vlax-curve-getClosestPointTo ent2 pt) 4) ; ( ; (lambda (mid) (grdraw mid (polar mid (+ (angle pt (vlax-curve-getClosestPointTo ent2 pt)) halfPi) (car corners)) 2)) ; (mapcar (function (lambda (a b) (* (+ a b) 0.5))) pt (vlax-curve-getClosestPointTo ent2 pt)) ; ) ; (vla-update ent1) ; (_wait 120) ; End animation ) )) (list ent1 ent2) (list ent2 ent1) ) (setq corners (vl-sort (append corners (_cornerOffset ent1 ent2) (_cornerOffset ent2 ent1)) '<) offsetdistance (/ maxlen 512.0)) (if (LM:intersections ent1 ent2 acExtendNone) ; For crossing polylines, add negative values (setq offset (- maxlen) corners (append (mapcar '- (reverse corners)) corners)) (setq offset 0.0) ) (setq gap (getvar 'offsetgaptype)) (setvar 'offsetgaptype 0) (while (progn (while (and corners (> offset (car corners))) ; Calculated offset values to check (_doOffset (car corners)) (setq corners (cdr corners)) ) (setq loop ; Incremental check (cond ((> offset maxlen) nil) ((_doOffset offset) (setq start t)) ((not start) t) (start nil) ) ) (setq offset (+ offset offsetdistance)) loop ) ) (setvar 'offsetgaptype gap) (if flipped (entmod enx2)) (if pts ; Draw polyline (_polyline (mapcar 'cadr (vl-sort pts (function (lambda (a b) (< (car a) (car b)))))) (and (vlax-curve-isClosed ent1) (vlax-curve-isClosed ent2)) ) ) ) ) (redraw) (princ) ) And here is an animation of it working just because they are fun to look at :3 points
-
Obviously we don't have your batch LISP - I guess your company paid for this and so you are not going to be popular sharing that for all online. LISPs can be added to scripts - both as a command and as code. There are others out there such as ScriptPro and Lee Macs Script Writer which will do this. BigAl will often post snippets of scripts here to batch process files - last one he did was in the last week or so ago. You could even set this up as a stand alone script to do just the one task (see BigAls last example....) The first step for all is to get a LISP working as you want and well on a single file and then to do it as a batch (first time running the batch with a new LISP, perhaps check carefully that it doesn't do anything unexpected on other files). Plenty of examples out there to change layer names from one to another - have a look to see if you see one you like to use, or if there isn't am sure we can put one together - and use what is above as a started if you want to have a go, I think all the code you need is in the examples, just need to think how to change them to your needs2 points
-
Hi everyone, I’ve been working on a small production tool in AutoLISP/VLISP for AutoCAD / Civil 3D and thought it might be useful to share here for anyone doing a lot of section or profile sheets. ## What problem it solves On corridor / section jobs we often end up with several paper-space viewports that all need to: - Use the same scale and twist - Stay aligned to a centerline / path (alignment, guide polyline, etc.) - Be re-centered after design changes The usual manual workflow for us was: 1. Set up one “master” viewport with the correct scale, twist, layers, etc. 2. Copy that viewport across the layout for each station/section. 3. Manually PAN/ZOOM/DVIEW in each viewport to center the correct station along the path. 4. Repeat that pan/zoom step any time the design or alignment changed. It works, but it’s tedious and easy to make mistakes when you have a lot of sheets. ## What SectionSync LITE does SectionSync LITE is a compiled VLX that: - Lets you pick a polyline path (e.g. alignment, section chain, etc.) - Associates multiple paper-space viewports with positions along that path - Updates the view center of each viewport so it “follows” the path - Preserves the existing viewport scale and twist - Can be re-run after design changes so you don’t have to manually re-pan everything It was written mainly with Civil 3D section/profile sheets in mind, but it’s just working with standard AutoCAD viewports and a polyline. ## Technical notes - Written in AutoLISP/Visual LISP and compiled to VLX for distribution. - Uses vla/vlax functions to read and set viewport center, width/height, and twist. - Path positions are based on cumulative distance along the selected polyline. - No reactors or custom objects – it just runs on demand and updates existing VPs. ## Demo + download Short demo video: https://youtu.be/l1JRbz4_owQ Download / more details (there’s a built-in 5-run / 7-day trial so you can test it on a real project): https://autolispwizard.gumroad.com/l/civabs If anyone is interested in the implementation details (polyline parameterization, handling UCS and VP twist, etc.) I’m happy to discuss approaches or share pseudo-code for the core parts.2 points
-
Great! Thanx! It did gave me an error after the first page so I changed one of your subs a little. added this line : (and blkRef (vlax-method-applicable-p blkRef 'Name)) (defun set-block-contents-color (blkRef layer color / blkDef) (if (and blkRef (vlax-method-applicable-p blkRef 'Name)) (progn (setq blkDef (vla-item (vla-get-Blocks doc) (vla-get-Name blkRef))) (vlax-for ent blkDef (vl-catch-all-apply 'vla-put-layer (list ent layer)) (vl-catch-all-apply 'vla-put-color (list ent color)) ) ) ) )2 points
-
With (initget) and (getkword) for choice precision... (vl-load-com) (defun c:change_prec ( / ss AcDoc Space prec_source ktarget n ename Obj value_string nbs tmp_nbs) (princ "\nSelect MText.") (while (null (setq ss (ssget (list '(0 . "*TEXT") (cons 67 (if (eq (getvar "CVPORT") 1) 1 0)) (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model")) ) ) ) ) (princ "\nAren't MText or Text!") ) (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) (initget 1 "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Current") (setq ktarget (getkword "\nPrecision of target number [0/1/2/3/4/5/6/7/8/9/10/11/12/13/14/15/16/Current]?: ")) (repeat (setq n (sslength ss)) (setq ename (ssname ss (setq n (1- n))) Obj (vlax-ename->vla-object ename) ) (setq value_string (vla-FieldCode Obj) nbs 0) (cond ((vl-string-search "%<\\" value_string nbs) (while nbs (if (setq nbs (vl-string-search "%pr" value_string (setq tmp_nbs nbs))) (setq prec_source (itoa (atoi (substr value_string (+ nbs 4) 2))) value_string (vl-string-subst (if (eq ktarget "Current") (strcat "%pr" (itoa (getvar "LUPREC"))) (strcat "%pr" ktarget) ) (strcat "%pr" prec_source) value_string tmp_nbs ) nbs (1+ nbs) ) ) ) (vlax-put Obj 'TextString value_string) ) ) ) (vla-endundomark AcDoc) (prin1) )2 points
-
I'll have to debug it when i get home just typed it up in note pad. -Edit Well if i took two seconds to look at the code. was using integers and needs to be strings. because Tusky is calling vl-string-subst. if its still bugged ill fix it tonight.2 points
-
You're welcome @Clint . Yes, the DCL file are not necessary every time, but it can be helpful and user-friendly to accomplish desired result (like this one from an example video from above) if you have multiple choosing (for eg. buttons or check-boxes for Uppercase, Lowercase, Renaming, etc.). Best regards.2 points
-
You can try this. (vl-load-com) (defun c:change_prec ( / ss AcDoc Space n ename Obj value_string nbs tmp_nbs) (princ "\nSelect MText.") (while (null (setq ss (ssget (list '(0 . "*TEXT") (cons 67 (if (eq (getvar "CVPORT") 1) 1 0)) (cons 410 (if (eq (getvar "CVPORT") 1) (getvar "CTAB") "Model")) ) ) ) ) (princ "\nAren't MText or Text!") ) (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) (repeat (setq n (sslength ss)) (setq ename (ssname ss (setq n (1- n))) Obj (vlax-ename->vla-object ename) ) (setq value_string (vla-FieldCode Obj) nbs 0) (cond ((eq (substr (vla-FieldCode Obj) 1 3) "%<\\") (while nbs (if (setq nbs (vl-string-search "%pr2" value_string (setq tmp_nbs nbs))) (setq value_string (vl-string-subst "%pr1" "%pr2" value_string tmp_nbs) nbs (1+ nbs) ) ) ) (vlax-put Obj 'TextString value_string) ) ) ) (vla-endundomark AcDoc) (prin1) )2 points
-
Maybe this kind of solution can be interesting (to use a multiple selection, use Shift+Left mouse click, to use a single selection, use CTRL+Left mouse click): ; ************************************************************************** ; Functions : CHRENLAYERS ; Description : Select Layers To Change It To UPPERCASE Or LOWERCASE ; Author : SAXLLE ; Date : December 04, 2025 ; ************************************************************************** (prompt "\nSelect Layers To Change It To UPPERCASE Or LOWERCASE!\nTo run a LISP type: CHRENLAYERS") (princ) (defun c:CHRENLAYERS ( / old_echo dcl_id fname fn laylist lay items rval acad name) (vl-load-com) (setq old_echo (getvar 'cmdecho)) (setvar 'cmdecho 0) (create_dialog) (collect_layers) (setq dcl_id (load_dialog fname)) (if (not (new_dialog "Laylist" dcl_id)) (exit) ) (action_tile "cancel" "(cancel)") (start_list "ls") (mapcar 'add_list laylist) (end_list) (action_tile "ps1" "(read_items) (to_uppercase)") (action_tile "ps2" "(read_items) (to_lowercase)") (start_dialog) (unload_dialog dcl_id) (vl-file-delete fname) (gc) (princ) ) (defun cancel () (done_dialog 0) (terpri) (prompt "Application running were finished...") (princ) ) (defun collect_layers () (setq laylist (list) lay (tblnext "LAYER" T) ) (while lay (if (not (equal (cdr (assoc 2 lay)) "0")) (setq laylist (cons (cdr (assoc 2 lay)) laylist) lay (tblnext "LAYER") ) (setq lay (tblnext "LAYER")) ) ) (setq laylist (vl-sort laylist '<)) ) (defun read_items () (setq acad (vla-get-activedocument (vlax-get-acad-object))) (setq items (get_tile "ls") rval (mapcar '(lambda (x) (nth x laylist)) (read (strcat "(" items ")"))) ) ) (defun to_uppercase () (foreach item rval (setq name (strcase item)) (vla-SendCommand acad (strcat "-RENAME LA " item (chr 13) name (chr 13))) (prompt (strcat "\nThe layer " item " were changed into the UPPERCASE!")) (setvar 'cmdecho old_echo) (princ) ) (done_dialog 1) ) (defun to_lowercase () (foreach item rval (setq name (strcase item T)) (vla-SendCommand acad (strcat "-RENAME LA " item (chr 13) name (chr 13))) (prompt (strcat "\nThe layer " item " were changed into the LOWERCASE!")) (setvar 'cmdecho old_echo) (princ) ) (done_dialog 1) ) (defun create_dialog () (setq fname (vl-filename-mktemp "Laylist.dcl") fn (open fname "w") ) (write-line "Laylist :dialog { label = \"Select layers to change it to UPPERCASE or LOWERCASE!\"; :list_box { key = \"ls\"; multiple_select = true; height = 10; width = 50; } :row { :button { label = \"Change to UPPERCASE >>\"; key = \"ps1\"; fixed_width = true; } :button { label = \"Change to LOWERCASE >>\"; key = \"ps2\"; fixed_width = true; } :button { label = \"Cancel\"; key = \"cancel\"; mnemonic = \"C\"; alignment = centered; fixed_width = true; is_cancel=true; } } }" fn) (close fn) ) Also, you can see the short video example of how it works. CHRENLAYERS.mp4 Best regards.2 points
-
It could be as simple as changing "all" to "ss", where ss is a selection set. I am no expert on setting the exclude objects in a selection set. try this not really tested. (setq ss (ssget "_X" '((-4 . "<NOT") (0 . "3DSOLID") (-4 . "NOT>")))) or _move;(setq ss (ssget "_X" '((-4 . "<NOT") (0 . "3DSOLID") (-4 . "NOT>"))));;0,0,0;0,0,1e99;_move;ss;;0,0,0;0,0,-1e992 points
-
You could try the search function... maybe this thread from lasty week might help?2 points
-
Have a look at (setq lays (layoutlist)) there is no Model in the list created saves a few if and buts. Can use also (setvar 'ctab "Model") so no Doc required.2 points
-
I’ve always thought that a centerline should keep the same distance to the left and right, in the direction of travel. But from a geometric standpoint, maybe it should be as you say.I won’t get into that controversy. Perhaps that approach does make it possible to obtain the centerline in more situations. Regarding @SLW210’s suggestion that I upload a drawing to put the proposed Lisp codes to the test, I think the most appropriate example is the bank of a small river. I trimmed a section and ran the codes by @dexus, @Lee Mac, @SLW210, @mhupp, and @GP_ on it. The geometry of the riverbanks seems to be quite stressful for all the codes, although Dexus’s code only loses control in a couple of areas. I’m attaching the file with all of this for anyone who wants to take a look. AxisExple2.dwg2 points
-
Good day everyone! I've discovered new (old?) the possibilities of a true rectangle. It is very convenient to work with him! The only drawback is that the rectangle is unstable. You can create it and work with it only in the current file. If you then close and open this file, the properties of the true rectangle are lost. Is it possible to make it stable so that its properties are preserved? https://autocadtips1.com/2011/11/20/autolisp-make-a-real-rectacgle/ AutoLISP: Make a Real Rectangle Posted on November 20, 2011 by AutoCAD Tips A long time ago, AutoCAD used to make Rectangles and polygons as their own entities. When you made a rectangle and then did a LIST <enter> on it, it would show as a rectangle. Nowadays, these objects are those objects in their geometry but are made of polyline entities. So modifying these objects is sometimes hard. that’s where this routine steps in to help. This routine lets you create a rectangle and even after you continue working elsewhere in your drawing, you can come back to that rectangle and modify that object and it acts like how rectangles used to act in AutoCAD. Here’s how: TREC <enter> to start “True RECtangle” Create a rectangle how you normally create one When needed, this routine will let you drag a single corner and the rest of the rectangle’s geometry will adjust accordingly to keep its geometry as a rectangle. TrueRect.lsp1 point
-
It can be done, but it requires creating a custom object using ObjectARX (C++).1 point
-
Ugh I think I watched your video too fast. I haven't had much time to do anything slowly lately I believe object reactors only survive the current drawing session. You must consider that the reactor was created relative to an object name, and object names change between drawing sessions.1 point
-
Inside the "initget" you use "Screening_50.ctb Fill_Patterns.ctb" with "_", and inside the "getkword" you use "Screening 50%.ctb/Fill Patterns.ctb", which is not equal as it in "initget". Everything must be equal. So, according from your's "initget", the "_" can't be in use, because it's in use for localization (for eg. "_RECTANG", "_LINE", etc.). From this link you can find this: Keyword Specifications The string argument is interpreted according to the following rules: 1. Each keyword is separated from the following keyword by one or more spaces. For example, "Width Height Depth" defines three keywords. 2. Each keyword can contain only letters, numbers, and hyphens (-). One of the possible solutions is to use this: (initget 1 "Monochrome.ctb acad.ctb Grayscale.ctb Screening50.ctb FillPatterns.ctb") (setq plotstyle (getkword "\nChoose plot style [Monochrome.ctb/acad.ctb/Grayscale.ctb/Screening50.ctb/FillPatterns.ctb] <Monochrome.ctb>:")) (cond ((equal plotstyle "Screening50.ctb") (setq plotstyle "Screening_50.ctb") ) ((equal plotstyle "FillPatterns.ctb") (setq plotstyle "Fill_Patterns.ctb") ) ) Best regards.1 point
-
@Clint Please give it a try (defun c:lay-nam-to-capital (/ (ACAD-OBJ ADOC LAY-COLL)) (VL-LOAD-COM) (SETQ ACAD-OBJ (VLAX-GET-ACAD-OBJECT)) (SETQ ADOC (VLA-GET-ACTIVEDOCUMENT ACAD-OBJ)) (SETQ LAY-COLL (VLA-GET-LAYERS ADOC)) (vlax-for lay lay-coll (vla-put-name lay (strcase (vla-get-name lay))) ) ;_ end of vlax-for ) ;_ end of defun1 point
-
Python, makes Batch processing a bit easier sometimes import traceback from pyrx import Ap, Db def capcaseLayers(db: Db.Database): lt = Db.LayerTable(db.layerTableId()) for name, id in lt.toDict().items(): l = Db.LayerTableRecord(id, Db.OpenMode.kForWrite) l.setName(name.upper()) def processDb(fpath: str): sdb = Db.Database(False, True) sdb.readDwgFile(fpath) sdb.closeInput(True) capcaseLayers(sdb) sdb.saveAs(fpath) #add new command @Ap.Command() def caplayers(): try: for fpath in Ap.Application.listFilesInPath("E:\\temp", ".dwg"): processDb(fpath) except Exception as err: traceback.print_exception(err)1 point
-
The PIP is here ‘pip install cad-pyrx’ https://pypi.org/project/cad-pyrx/, the project is here https://github.com/CEXT-Dan/PyRx It’s an amalgamation of BRX and ActiveX APIs. There’s some stuff for BIM as well.1 point
-
If using a script and running it over multiple dwgs then yes can load a lisp and then run it. The lisp can be very extensive a few lines or even hundreds. Open dwg1 (load "updatelisp") (c:updatelisp) close Y Open dwg2 (load "updatelisp") (c:updatelisp) close Y Open dwg3 (load "updatelisp") (c:updatelisp) close Y1 point
-
maybe its just a matter of name vs effective block name issue , haven't tested that. But I like the routine and maybe gonna extend it a little with above suggestions if I run into a project that could benefit from this. Did find a program , I think it's called able2extact or something , that also has OCR built in but it will set you back around two hundred dollars , lifte time subscription.1 point
-
Like @rlx this is a hard coded plot pdf using preset values, our dwg's used layouts one title block. the code is hard coded for a A1 sheet plotted as a A3 size. We just walked through the layouts and plotted. So does not matter what current plot settings are as they are ignored. We had multiple devices PDF, A1, A3 Color, A3 B-W. So code for each. (setvar "textfill" 1) (setvar "fillmode" 1) (COMMAND "-PLOT" "Y" "" "Plot To PDF" "Iso full bleed A3 (420.00 x 297.00 MM)" "m" "LANDSCAPE" "N" "W" "-6,-6" "807,560" "1=2" "C" "y" "Acad.ctb" "Y" "n" "n" "n" pdfName "N" "y" )1 point
-
@SLW210 have a look at this by Lee-mac may be useful. I did have problems may be my Bricscad or pdf I am using. https://www.theswamp.org/index.php?PHPSESSID=a86a2d2e880b6079f1d3aee842f41d9d&topic=39001.msg441632#msg441632 This may also be useful once you know count. (if (not AH:getvalsm)(load "Multi Getvals.lsp")) (setq vals (AH:getvalsm (list "Enter Pdf range" "Enter start Pdf number" 6 4 "1" "Enter end Pdf number" 6 4 (RTOS COUNT 2 0)))) ("1" "22")1 point
-
First of all , welcome to Cadtutor AutoLisp Wizard! My kind of work is 99% electrical & instrument loop diagrams so I don't often have to work with viewports and when I do its just for simple cabinet views and some instrument layouts. But I do appreciate users who contribute and share their hard work with other users , so although I'm not gonna use it my self , thank you for your contribution.1 point
-
maybe just something simple as : (setvar "filedia" 0) (command ".-plot" "No" "" "" "" (strcat (getvar 'dwgprefix) (getvar 'ctab) ".pdf") "No" "Yes") (setvar "filedia" 1)1 point
-
1 point
-
AutoCAD is very bad at running a LISP in one file to read another file, it is not something I have looked at with xrefs, however this might give you a starter, listing any xrefs in the current file - I was looking at this to do something different and is in the folder "finish this one day"... so the code might not be 100%. ;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/grab-all-xref-names-and-paths/td-p/1661552 ;;(defun filepfil ( / Doc LayoutCol EndList) ;; Returns a list of list of all the Xrefs and Images with their paths within a drawing. (defun c:xreffilepaths ( / ) (defun xreftype ( str / ) ;; (setq lst (list "abcd.dwg" "1234.dwg" "sample drawing with space in file name.dwg" "5566.dwg") ) ;; (mapcar '(lambda (x) ;; (substr x 1 (- (strlen x) 4)) ;; ) ;; lst ;; ) (setq MyLen (strlen str)) (setq MyType (substr str (- MyLen 3) )) ) (setq Doc (vla-get-ActiveDocument (vlax-get-Acad-Object))) (setq LayoutCol (vla-get-Layouts Doc)) (vlax-for i LayoutCol (vlax-for Obj (vla-get-Block i) (cond ((= (vla-get-ObjectName Obj) "AcDbRasterImage") (if (not (assoc (vla-get-Name Obj) EndList)) (setq EndList (cons (cons (vla-get-Name Obj) (vla-get-ImageFile Obj)) EndList)) ) ) ((and (= (vla-get-ObjectName Obj) "AcDbBlockReference") (vlax-property-available-p Obj 'Path)) (if (not (assoc (vla-get-Name Obj) EndList)) (setq EndList (cons (cons (vla-get-Name Obj) (vla-get-Path Obj)) EndList)) ) ) ) ) ) EndList (princ "\nContains Xrefs: ") (princ EndList) (foreach n EndList (if (findfile (cdr n)) () (progn (princ "\nMissing XREF: ") (princ (car n)) ;; (princ n) ) ; end progn ) ; end if ) ; end foreach (setq MyPath (cdr (nth 0 EndList)) ) (setq MyFileType (xreftype (cdr (nth 0 EndList)) )) (setq MyFile (strcat (car (nth 0 EndList)) MyFileType) ) (setq NewPath (strcat (getvar "dwgprefix") (vl-string-trim ".\\\\" MyPath ) )) (if (findfile NewPath) ; find file : if file exists (progn (setq MyPath (vl-string-right-trim MyFile MyPath )) ; take off file from file path (setq NewPath (vl-string-right-trim MyFile NewPath )) ; take off file from file path ) ; end progn (progn ) ; end progn ) ; end if ) Not sure if this is something you can use? https://www.autodesk.com/support/technical/article/caas/sfdcarticles/sfdcarticles/Determining-whether-a-drawing-is-referenced-as-an-xref-in-other-drawings.html1 point
-
Use CLASSICXREF will display a window for you to look thought. for the ones that you suspect to be circular switch to overlay.1 point
-
1 point
-
Thank you @marko_ribar much simpler. Added look in current Layout or Model. In Civ3D may find surfaces also that are not displayed. (ssget "_X" (list (cons 0 "~3DSOLID")(cons 410 (getvar 'ctab))))1 point
-
K updated my code as well. tho this seems to not work well with BricsCAD. moved the vlax-put to only update when the if statment is true. change_prec_fields_update.lsp1 point
-
@Saxlle just a comment a bit hard to see what is going on in video maybe use a screen area rather than full screen. Win 11, Shit+Window+R allows screen area record. Drag window area then start / stop. This may be useful rather than a list box can tick one or all choices, add an All option so one click. Examples in code. Multi toggles.lsp1 point
-
And with this syntax? (sssetfirst nil (ssget "_X" '((0 . "*") (-4 . "<NOT") (0 . "3DSOLID") (-4 . "NOT>"))))1 point
-
Added a little on the front end to wrap it all in one command with user input options. Should display something like this Change_Prec or CP Enter "C" for Custom Values Choose Percision From:To : [1:2 1:3 2:1 2:3 3:1 3:2]: 3:2 Changing Select MText Precision From [3] to [2] ... Change_Prec or CP Enter "C" for Custom Values Choose Percision From:To : [1:2 1:3 2:1 2:3 3:1 3:2]: C Existing Precision: 1 Precision Change to: 4 Changing Select MText Precision From [1] to [4] ... Change_Prec 2 1 Changing Select MText Precision From [2] to [1] ... -Edit Updated it so you can just type "Change_Prec 3 2" and skip all that and just start asking you to make a selection.1 point
-
Always been a fan of CMS. I had meant to test out v14 back when it was released, I think I couldn’t find the SDK or something. Anyway, Let’s check it. Good looking interface, Ribbon, menu bar, and title bar. I don’t do drawings much, so I’m mainly going to test out the IRX API. I’ve opened a few good size drawings, it seems responsive, zooming and panning is plenty fast.1 point
-
@BIGAL that was the essence of my suggestion about 100 posts ago (October 22). The results rely to heavily on the relative distribution of vertices (quantity and spacing) between the two polylines.1 point
-
1 point
-
1 point
-
Let’s setup IRX and see how it compares to ARX I setup an ENV path IRX14 that points to the SDK. I didn’t see any documentation on how to setup a project from scratch. But there is a wizard for visual studio. I’ve had done this before, basically, I brute force it. There is documentation for .NET and ODA stuff.1 point
-
1 point
-
@SLW210 This weekend i finished a LISP that does exactly what i need, since there doesnt seem te be a regular AutoCAD-Map3D function for this. This code collects all object data on a layer, creates a 'exportprofile' for this specific layer and export this to its own SHP File. Since all EPF files are created for an individual layer, each SHP only gets the assigned ObjectData instead of 'All' objectdata in the DWG. code is based on the Dutch NLCS Cad standard for layer detection versus points/lines/polygons. ;;; ------------------------------------------------------------ ;;; MAPEXP_OD_ALL.LSP ;;; Export each layer to its own SHP using -MAPEXPORT + per-layer EPF ;;; - One SHP per layer in a subfolder: ;;; <DWGNAME>_YYYYMMDD_HHMMSS under the DWG folder ;;; - Uses DWGTITLED: if DWG not saved, alert & abort ;;; - Geometry type controlled by layer name suffix: ;;; * -S -> Point ;;; * -G -> Line ;;; * -GV -> Polygon ;;; Layers without those suffixes fall back to first-entity detection. ;;; - Per-layer Object Data (OD) mapped via ExpressionFieldMappings ;;; - EPF filters by that layer (DoFilterByLayer=1 + LayerList) ;;; - Treats closed polylines as polygons ;;; - Temp EPF is deleted after export ;;; - If SHP already exists: Overwrite via default ENTER, Load Profile? = Y ;;; - SHP filename: all '.' in the *layer name* are changed to ',' in the output file ;;; ------------------------------------------------------------ (vl-load-com) ;;; Global export folder (set in c:MAPEXP_OD_ALL) (setq *mapexp-export-folder* nil) ;;; --- small helpers --- (defun mapexp-get-dwg-folder ( / p ) ;; Use DWGPREFIX; ensure it ends with a backslash (setq p (getvar "DWGPREFIX")) (if (and p (/= p "") (/= (substr p (strlen p) 1) "\\")) (setq p (strcat p "\\")) ) p ) (defun mapexp-pad2 (n) ;; Pad single digit to 2 chars (e.g. 7 -> "07") (if (< n 10) (strcat "0" (itoa n)) (itoa n)) ) (defun mapexp-get-datetime ( / s lst ) ;; Get current date/time using EDTIME (compatible across versions) ;; Returns list: (year month day hour minute second) ;; %Y = year, %m = month, %d = day, %H = hour, %M = minute, %S = second ;; EDTIME format here: "YYYY MM DD HH MM SS" (setq s (menucmd "M=$(edtime,$(getvar,DATE),YYYY MM DD HH MM SS)")) ;; s is like "2025 11 21 14 32 05" ;; Turn it into "(2025 11 21 14 32 05)" and READ it (setq lst (read (strcat "(" s ")"))) lst ) (defun mapexp-get-export-folder ( / base path dt year mon day hh mm ss folder ) ;; Create export folder: ;; <DWGNAME_without_ext>_YYYYMMDD_HHMMSS ;; in the same folder as the DWG (setq path (getvar "DWGPREFIX")) (setq base (vl-filename-base (getvar "DWGNAME"))) ;; Use EDTIME-based datetime function (setq dt (mapexp-get-datetime)) (setq year (itoa (nth 0 dt))) (setq mon (mapexp-pad2 (nth 1 dt))) (setq day (mapexp-pad2 (nth 2 dt))) (setq hh (mapexp-pad2 (nth 3 dt))) (setq mm (mapexp-pad2 (nth 4 dt))) (setq ss (mapexp-pad2 (nth 5 dt))) (setq folder (strcat path "SHP_OD_EXPORT_" base "_" year mon day "_" hh mm ss "\\") ) ;; Create folder if it doesn't exist yet (if (not (vl-file-directory-p folder)) (vl-mkdir folder) ) folder ) (defun mapexp-sanitize-filename ( name / bad i ch ) ;; Replace characters that are invalid in file names (setq bad (list 34 42 47 58 60 62 63 92 124)) ; " * / : < > ? \ | (setq i 0) (while (< i (strlen name)) (setq ch (ascii (substr name (1+ i) 1))) (if (member ch bad) (setq name (strcat (substr name 1 i) "_" (substr name (+ i 2)) ) ) (setq i (1+ i)) ) ) name ) ;;; For the OUTPUT FILE NAME ONLY: ;;; - change '.' to ',' in the layer name ;;; - then sanitize for filesystem (quotes, *, /, :, <, >, ?, \, |) (defun mapexp-make-output-name (lay / s) (setq s lay) ;; Replace all dots with commas (setq s (vl-string-subst "," "." s)) ;; Remove OS-invalid characters but keep spaces, dashes, commas, etc. (setq s (mapexp-sanitize-filename s)) s ) (defun mapexp-first-entity-on-layer ( lay / ss ent ) (setq ss (ssget "X" (list (cons 8 lay)))) (if (and ss (> (sslength ss) 0)) (ssname ss 0) nil ) ) ;;; Fallback geometry detection – if no suffix rule hit (defun mapexp-geometry-type-from-entity ( ent / ed typ flags ) ;; Returns one of "Point" "Line" "Polygon" or nil (setq ed (entget ent)) (setq typ (cdr (assoc 0 ed))) (cond ((member typ '("POINT" "MULTILEADER" "INSERT")) "Point") ((member typ '("LINE" "ARC" "CIRCLE")) "Line") ((member typ '("LWPOLYLINE" "POLYLINE")) (setq flags (cdr (assoc 70 ed))) (if (and flags (= (logand flags 1) 1)) "Polygon" "Line" ) ) ((member typ '("SPLINE")) "Line") ((member typ '("HATCH" "POLYGON")) "Polygon") (T nil) ) ) ;;; Geometry type forced by layer name suffix (defun mapexp-geomtype-from-layername ( lay / ) ;; rules: ;; * -GV -> Polygon ;; * -S -> Point ;; * -G -> Line (cond ((wcmatch lay "*-GV") "Polygon") ((wcmatch lay "*-S") "Point") ((wcmatch lay "*-G") "Line") (T nil) ) ) ;;; Sanitize a string to be a valid FDO property name: ;;; - Only A–Z, a–z, 0–9, _ ;;; - If first char is not a letter or _, prefix with "F_" (defun mapexp-sanitize-fdo-name (s / i ch result) (if (not s) (setq s "FDO_NAME")) (setq result "") (setq i 1) (while (<= i (strlen s)) (setq ch (substr s i 1)) (if (wcmatch ch "[A-Za-z0-9_]") (setq result (strcat result ch)) (setq result (strcat result "_")) ) (setq i (1+ i)) ) ;; make sure first char is letter or _ (if (or (= result "") (not (wcmatch (substr result 1 1) "[A-Za-z_]")) ) (setq result (strcat "F_" result)) ) result ) ;;; Get unique OD table names used on a given layer (defun mapexp-get-od-tables-on-layer (layname / ss i e odtabs tbls tabName) (setq tbls '()) (setq ss (ssget "X" (list (cons 8 layname)))) ; all ents on layer (if ss (progn (setq i 0) (while (< i (sslength ss)) (setq e (ssname ss i) odtabs (ade_odgettables e) ; Map 3D ADE function ) (foreach tabName odtabs (if (and tabName (not (member tabName tbls))) (setq tbls (cons tabName tbls)) ) ) (setq i (1+ i)) ) ) ) (reverse tbls) ) ;;; --- EPF writer: SHP + OD + layer filter --- (defun mapexp-write-epf-with-od ( epfpath geomType layName odTabs / file tabName def_tbl cols col colName colType dataType usedNames outName baseName idx ) ;; geomType must be "Point" "Line" or "Polygon" (setq file (open epfpath "W")) (if (null file) nil (progn ;; Header – based on working AdMapExportProfile structure for SHP (princ "<AdMapExportProfile version=\"2.1.3\">" file) (princ "<LoadedProfileName/>" file) (princ "<StorageOptions>" file) (princ "<StorageType>FileOneEntityType</StorageType>" file) (princ "<GeometryType>" file) (princ geomType file) (princ "</GeometryType><FilePrefix/></StorageOptions>" file) ;; Auto-selection; filter by layer below (princ "<SelectionOptions><UseSelectionSet>0</UseSelectionSet><UseAutoSelection>1</UseAutoSelection></SelectionOptions>" file) (princ "<TranslationOptions>" file) ;; treat closed polylines as polygons (princ "<TreatClosedPolylinesAsPolygons>1</TreatClosedPolylinesAsPolygons>" file) (princ "<ExplodeBlocks>1</ExplodeBlocks>" file) (princ "<LayersToLevels><MapLayersToLevels>0</MapLayersToLevels><LayerToLevelMapping/></LayersToLevels>" file) (princ "</TranslationOptions>" file) (princ "<TopologyOptions><GroupComplexPolygons>0</GroupComplexPolygons><TopologyName/></TopologyOptions>" file) ;; Filter by this layer only (princ "<LayerOptions>" file) (princ "<DoFilterByLayer>1</DoFilterByLayer>" file) (princ "<LayerList>" file) (princ layName file) (princ "</LayerList>" file) (princ "</LayerOptions>" file) (princ "<FeatureClassOptions><DoFilterByFeatureClass>0</DoFilterByFeatureClass><FeatureClassList/></FeatureClassOptions>" file) ;; TableDataType "None" – OD via ExpressionFieldMappings (princ "<TableDataOptions>" file) (princ "<TableDataType>None</TableDataType>" file) (princ "<Name/>" file) (princ "<SQLKeyOnly>0</SQLKeyOnly>" file) (princ "</TableDataOptions>" file) (princ "<CoordSysOptions><DoCoordinateConversion>0</DoCoordinateConversion><CoordSysName/></CoordSysOptions>" file) ;; SHP target (princ "<TargetNameOptions><FormatName>SHP</FormatName></TargetNameOptions>" file) (princ "<DriverOptions/>" file) (princ "<UseUniqueKeyField>0</UseUniqueKeyField><UseUniqueKeyFieldName>AdMapKey</UseUniqueKeyFieldName>" file) ;; ===== OD ExpressionFieldMappings ===== (princ "<ExpressionFieldMappings>" file) (setq usedNames '()) ; track used attribute names to avoid duplicates (foreach tabName odTabs (setq def_tbl (ade_odtabledefn tabName)) ;; ADE table definition ;; def_tbl: (("TableName" . "...") ("Description" . "...") ("Columns" . ( ... ))) (setq cols (cdr (assoc "Columns" def_tbl))) (foreach col cols (setq colName (cdr (assoc "ColName" col))) (setq colType (cdr (assoc "ColType" col))) (if colName (progn ;; Map OD type to EPF Datatype (setq dataType (cond ((and colType (wcmatch (strcase colType) "*INT*")) "IntegerDataType" ) ((and colType (wcmatch (strcase colType) "*REAL*,*DOUBLE*,*FLOAT*,*NUM*")) "DoubleDataType" ) (T "CharacterDataType") ) ) ;; Decide attribute (FDO property) name: ;; - sanitize to valid FDO name ;; - if duplicate, append 2,3,... (setq baseName (mapexp-sanitize-fdo-name colName)) (setq outName baseName idx 1 ) (while (member (strcase outName) usedNames) (setq idx (1+ idx)) (setq outName (strcat baseName (itoa idx))) ) (setq usedNames (cons (strcase outName) usedNames)) ;; <NameValuePair> mapping: ;; <Name>outName</Name> -> FDO-safe property name ;; <Value>:ColName@Table</Value> -> actual OD mapping ;; <Datatype>...</Datatype> (princ "<NameValuePair><Name>" file) (princ outName file) (princ "</Name><Value>:" file) (princ colName file) (princ "@" file) (princ tabName file) (princ "</Value><Datatype>" file) (princ dataType file) (princ "</Datatype></NameValuePair>" file) ) ) ) ) (princ "</ExpressionFieldMappings>" file) (princ "</AdMapExportProfile>" file) (close file) T ) ) ) ;;; --- main export per layer --- (defun mapexp-export-layer-to-shp ( lay / ent geomType dwgFolder shpName shpFull epfFull odTabs ok ) ;; Prefer explicit geometry from layer name; fall back to entity if not matched (setq geomType (mapexp-geomtype-from-layername lay)) (if (null geomType) (progn (setq ent (mapexp-first-entity-on-layer lay)) (if (null ent) (setq geomType nil) (setq geomType (mapexp-geometry-type-from-entity ent)) ) ) ) (if (null geomType) nil (progn ;; Use the global export folder instead of the DWG folder (setq dwgFolder *mapexp-export-folder*) ;; SHP base name: layer name, but '.' -> ',' and OS-invalid chars cleaned (setq shpName (mapexp-make-output-name lay)) (setq shpFull (strcat dwgFolder shpName ".shp")) (setq epfFull (strcat dwgFolder shpName "_temp_export.epf")) ;; OD tables used on this layer (setq odTabs (mapexp-get-od-tables-on-layer lay)) ;; EPF for this geometry type + layer OD + layer filter (setq ok (mapexp-write-epf-with-od epfFull geomType lay odTabs)) (if ok (progn ;; If SHP already exists, we expect Overwrite prompt: ;; This file already exists. Enter an option [Overwrite/Cancel] <Overwrite>: ;; -> we send "" (ENTER) to accept default Overwrite ;; Then: Load Profile? [Yes/No] <No>: -> we send "Y" (princ "\n") (if (findfile shpFull) (command "-MAPEXPORT" "SHP" shpFull "" ; Overwrite? -> ENTER = default Overwrite "Y" ; Load Profile? Yes epfFull "Proceed" ) (command "-MAPEXPORT" "SHP" shpFull "Y" ; Load Profile? Yes (no overwrite prompt) epfFull "Proceed" ) ) ;; Delete temp EPF (if (findfile epfFull) (vl-file-delete epfFull) ) T ) nil ) ) ) ) ;;; --- public command --- (defun c:MAPEXP_OD_ALL ( / lay rec ) (vl-load-com) ;; Check if drawing is saved (if (= (getvar "DWGTITLED") 0) (progn (alert "Deze tekening is nog niet opgeslagen.\n\nSla de DWG eerst op en start MAPEXP_OD_ALL daarna opnieuw." ) (princ) ) (progn (setvar "CMDECHO" 0) ;; Create export folder for this run (setq *mapexp-export-folder* (mapexp-get-export-folder)) (prompt (strcat "\nMAPEXP_OD_ALL – exportfolder: " *mapexp-export-folder* ) ) ;; loop through all layers in the table (setq rec (tblnext "LAYER" T)) (while rec (setq lay (cdr (assoc 2 rec))) ; layer name ;; skip xref layers (contain "|") (if (not (wcmatch lay "*|*")) (mapexp-export-layer-to-shp lay) ) (setq rec (tblnext "LAYER")) ) (setvar "CMDECHO" 1) (prompt "\nMAPEXP_OD_ALL – done.") (princ) ) ) )1 point
-
1 point
-
Anyway, the result obtained by Dexus's code is one of the best (perhaps the best) I've found on the web. Thanks for that, Dexus1 point
-
In the voronoi version some error checking before trying to call _polyline should be added indeed. And this function is dependent on how well the points are distributed over the line (ent->pts function). For the lines close together, more points should be given and with crossing lines it will not work at all. It only works if the lines stay in between the two polylines, and it doesn't in the example from OP:1 point
