ScottMC Posted Wednesday at 03:20 AM Posted Wednesday at 03:20 AM (edited) Question in code.. (defun c:CopyRegionEdge (/ ss) ;; AI.. https://www.google.com/search?q=copy+region+edge+segment%2C+autolisp&client=firefox-b-1-e&hs=LJSp&sca_esv=28d160b4388e87a1&biw=1143&bih=530&ei=t2enadf8OfXIp84PyJ69kA8&ved=0ahUKEwiXtPqy6oSTAxV15MkDHUhPD_I4ChDh1QMIEQ&uact=5&oq=copy+region+edge+segment%2C+autolisp&gs_lp=Egxnd3Mtd2l6LXNlcnAiImNvcHkgcmVnaW9uIGVkZ2Ugc2VnbWVudCwgYXV0b2xpc3AyCBAAGIAEGKIEMgUQABjvBTIFEAAY7wUyBRAAGO8FMgUQABjvBUjeM1C3D1iRLnABeACQAQCYAYgIoAHMC6oBBzAuNC43LTG4AQPIAQD4AQGYAgagApcNwgIIEAAYsAMY7wXCAgoQIRigARjDBBgKmAMAiAYBkAYFkgcHMS40LjYtMaAH0BCyBwcwLjQuNi0xuAffDMIHBzItMS4zLjLIB2uACAA&sclient=gws-wiz-serp ;; micro altered.. (princ "\nSelect Region to Copy Edge From: ") (setvar 'cmdecho 0) (if (setq ss (ssget ":S" '((0 . "REGION")))) (progn (command "_.copybase" "0,0,0" ss "") ;; copy region to clipbrd (command "chprop" ss "" "c" 252 "") ;; change color ;;; ??????????? (command "_.explode" ss) ;; make segs accessable <not a selection set> (princ "\nSelect Region Seg to Copy ") (command "_.copy" (ssget ":S") "" "\\" "\\") ;; select seg +copy +move (command "_.erase" ss "") (princ "\nSelect Items to Remove..") ;; <- my only known method (command "_.erase" "w" "\\" "\\" "") ;; <- manual erase :( ;; ... SEEING AS MY AUTOLISP EXPERIENCE SUCKS .. ;; how can the eXploded region / lines etc, be ERASED/selected ? ;; how to: make a selection set? (command "chprop" "_L" "" "c" "bylayer" "") ;; ch copied to bylayer ) ) (command "_.pasteclip" "0,0,0") ;; re.place original region (setvar 'cmdecho 1) (princ) ) Edited Wednesday at 03:23 AM by ScottMC .. Quote
mhupp Posted Wednesday at 04:49 AM Posted Wednesday at 04:49 AM not sure what your trying to do. you can set entlast before the explode then add all the entities into the selection set. (setq LastEnt (entlast)) (command "_.explode" ss) (setq SS1 (ssadd)) ;create a blank selection set or add to an existing one. (while (setq LastEnt (entnext LastEnt)) (ssadd LastEnt SS1) ) 1 Quote
marko_ribar Posted Wednesday at 01:10 PM Posted Wednesday at 01:10 PM (edited) If I understood you correctly, you are searching to something like this... (defun c:copy_reg_edg ( / *error* car-sort osm cmd pt ptt regpt reg x el ell edg edgs ss m ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun *error* ( m ) (if osm (setvar (quote osmode) osm) ) (if cmd (setvar (quote cmdecho) cmd) ) (if m (prompt (strcat "\n" m)) ) (princ) ) (defun car-sort ( lst fun / r ) (setq r (car lst)) (foreach itm (cdr lst) (if (apply fun (list itm r)) (setq r itm) ) ) r ) (setq osm (getvar (quote osmode))) (setvar (quote osmode) 3) (setq cmd (getvar (quote cmdecho))) (setvar (quote cmdecho) 0) (if (and (not (initget 1)) (setq pt (getpoint "\nPick edge of region to copy - you may use any OSNAP option; hover cursor over segment mid, or end point to see active OSNAP - <end,mid>... : ")) (setq regpt (nentselp pt)) (setq reg (car regpt)) (= (cdr (assoc 0 (setq x (entget reg)))) "REGION") (/= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 x)))))))) (progn (setq ptt (trans pt 1 0)) (setq el (entlast)) (vla-explode (vlax-ename->vla-object reg)) (while (setq el (entnext el)) (setq ell (cons el ell)) ) (if (not (equal pt (osnap pt "_end"))) (progn (setq edg (car-sort ell (function (lambda ( a b ) (< (distance ptt (vlax-curve-getclosestpointto a ptt)) (distance ptt (vlax-curve-getclosestpointto b ptt))))))) (foreach el ell (if (not (eq el edg)) (entdel el) ) ) (vl-cmdf "_.move" edg "" "_non" (trans ptt 0 1) "\\") ) (progn (setq ell (vl-sort ell (function (lambda ( a b ) (< (distance ptt (vlax-curve-getclosestpointto a ptt)) (distance ptt (vlax-curve-getclosestpointto b ptt))))))) (setq edgs (list (car ell) (cadr ell))) (foreach el (cddr ell) (entdel el) ) (setq ss (ssadd)) (ssadd (car edgs) ss) (ssadd (cadr edgs) ss) (vl-cmdf "_.move" ss "" "_non" (trans ptt 0 1) "\\") ) ) ) (setq m "Missed, or picked wrong entity type - you must pick REGION entity on unlocked Layer... Better luck next time...") ) (*error* (if m m)) ) Edited Wednesday at 04:31 PM by marko_ribar Quote
ScottMC Posted Wednesday at 01:10 PM Author Posted Wednesday at 01:10 PM PURRRFECT! Thanks so much 'mhupp This gets me all.the.more excited to learn more! Quote
ScottMC Posted Wednesday at 01:13 PM Author Posted Wednesday at 01:13 PM (edited) Marco, when'd u write that? let me try it... seems to refuse arc segs but do like your select style Edited Wednesday at 01:26 PM by ScottMC Quote
marko_ribar Posted Wednesday at 02:25 PM Posted Wednesday at 02:25 PM I tested it under AutoCAD 2022 and BricsCAD V26 and it worked well and with arced segments... Do you receive some error messages? Quote
ScottMC Posted Wednesday at 03:16 PM Author Posted Wednesday at 03:16 PM (defun c:crs (/ *error* _StartUndo _EndUndo ss ss1) ;; AI.. https://www.google.com/search?q=copy+region+edge+segment%2C+autolisp&client=firefox-b-1-e&hs=LJSp&sca_esv=28d160b4388e87a1&biw=1143&bih=530&ei=t2enadf8OfXIp84PyJ69kA8&ved=0ahUKEwiXtPqy6oSTAxV15MkDHUhPD_I4ChDh1QMIEQ&uact=5&oq=copy+region+edge+segment%2C+autolisp&gs_lp=Egxnd3Mtd2l6LXNlcnAiImNvcHkgcmVnaW9uIGVkZ2Ugc2VnbWVudCwgYXV0b2xpc3AyCBAAGIAEGKIEMgUQABjvBTIFEAAY7wUyBRAAGO8FMgUQABjvBUjeM1C3D1iRLnABeACQAQCYAYgIoAHMC6oBBzAuNC43LTG4AQPIAQD4AQGYAgagApcNwgIIEAAYsAMY7wXCAgoQIRigARjDBBgKmAMAiAYBkAYFkgcHMS40LjYtMaAH0BCyBwcwLjQuNi0xuAffDMIHBzItMS4zLjLIB2uACAA&sclient=gws-wiz-serp (princ "\nSelect Region to Copy Edge From: <oops> ") ;; micro altered.. ;; https://www.cadtutor.net/forum/topic/99013-segment-copy-of-a-region-cleaning-request/#findComment-678508 (setvar 'cmdecho 0) (defun *error* ( msg ) (setvar 'cmdecho 0) ;; 5.28.24 (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if msg (prompt (strcat "\n" msg))) (setvar 'nomutt 0) (setvar 'cmdecho 1) (princ) ) (defun _StartUndo ( doc ) (_EndUndo doc) (vla-StartUndoMark doc) ) (defun _EndUndo ( doc ) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndoMark doc) ) (princ "\r") ;; added to merge final info/cmd-line ) (setvar 'nomutt 1) ;; bypass ssget 'select prompt (if (setq ss (ssget ":S" '((0 . "REGION")))) (progn (command "_.copybase" "0,0,0" ss "") ;; copy region to clipbrd (command "chprop" ss "" "c" 252 "") ;; change color (setq LastEnt (entlast)) ;; ;;; !!!!!!!!!!!!!!!! (_StartUndo doc) (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (command "_.explode" ss) ;; make segs accessable, saved in 'ss to erase (setq SS1 (ssadd)) ;; create a blank selection set or add to an existing one., saved in 'SS1 to erase (while (setq LastEnt (entnext LastEnt)) (ssadd LastEnt SS1) ) (princ "\nSelect Region Segment to Copy ") (initget 1) (command "_.copy" (ssget ":S")) ;; select segment (setvar 'nomutt 1) (princ "\nSpecify Basepoint: ") (command "" "\\") (princ "\nSpecify Destination: ") (command "\\") ;; +move (setvar 'nomutt 0) (command "_.erase" ss "") ;; region copied/erasure (command "_.erase" ss1 "") ;; erases exploded region (_EndUndo doc) ; (princ "\nSelect Items to Remove..") ;; <- my only known method \ ; \ ; (command "_.erase" "w" "\\" "\\" "") ;; <- manual erase :( -- solved!!! ; / ;; ... SEEING AS MY AUTOLISP EXPERIENCE SUCKS .. / ;; how can the eXploded region / lines etc, be ERASED/selected ? / ;; how to: make a selection set? / (command "chprop" "_L" "" "c" "bylayer" "") ;; ch copied to bylayer ) ;; end of progn ;;(c:crs) ) ;; end of if (command "_.pasteclip" "0,0,0") ;; re.place original region (setvar 'nomutt 0) (setvar 'cmdecho 1) (*error* nil) (princ) ) Only oops is when I rt.clk after selecting region .. tried 'initget 1 but no fixy just so glad this works. Thanks again Mr. mhupp Quote
ScottMC Posted Wednesday at 11:26 PM Author Posted Wednesday at 11:26 PM Got to my original desire.. to enable access to region coords/osnaps though gonna tweak/twist to enable transparency. Thanks much mhupp for code enabling functionality! <any other training affordable!> (defun c:prv (/ *error* ss ss1 cec doc lastent html p) ;; AI.. https://www.google.com/search?q=copy+region+edge+segment%2C+autolisp&client=firefox-b-1-e&hs=LJSp&sca_esv=28d160b4388e87a1&biw=1143&bih=530&ei=t2enadf8OfXIp84PyJ69kA8&ved=0ahUKEwiXtPqy6oSTAxV15MkDHUhPD_I4ChDh1QMIEQ&uact=5&oq=copy+region+edge+segment%2C+autolisp&gs_lp=Egxnd3Mtd2l6LXNlcnAiImNvcHkgcmVnaW9uIGVkZ2Ugc2VnbWVudCwgYXV0b2xpc3AyCBAAGIAEGKIEMgUQABjvBTIFEAAY7wUyBRAAGO8FMgUQABjvBUjeM1C3D1iRLnABeACQAQCYAYgIoAHMC6oBBzAuNC43LTG4AQPIAQD4AQGYAgagApcNwgIIEAAYsAMY7wXCAgoQIRigARjDBBgKmAMAiAYBkAYFkgcHMS40LjYtMaAH0BCyBwcwLjQuNi0xuAffDMIHBzItMS4zLjLIB2uACAA&sclient=gws-wiz-serp (princ "\nPOints on Region Segment Vertex..(M) <oops> ") ;; https://www.cadtutor.net/forum/topic/99013-segment-copy-of-a-region-cleaning-request/#findComment-678508 ;; ESC cancels leaving lines <under region/ RT.CLK erases/cleans segments made/used (setvar 'cmdecho 0) (vl-load-com) ;; (defun *error* ( msg ) (setvar 'cmdecho 0) ;; 5.28.24 (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if msg (prompt (strcat "\n" msg))) (if (= fin 1) (command "_.pasteclip" "0,0,0")) ;; restores region if incomplete (setvar 'cecolor "bylayer") ;; ch copied to bylayer (setvar 'nomutt 0) (setvar 'cmdecho 1) (princ) ) ;;//------ BIGAL ----;; https://www.cadtutor.net/forum/topic/24751-timing/#findComment-199009 (defun ddelay (d / cd);;; (ddelay 1e-6) = 1 Second (setq cd (getvar "CDATE")) (while (> (+ cd d) (getvar "CDATE"))) ) (defun ftp () ;; uses 'p for coords (princ (setq pp ;; make/prints coords & paste usable (strcat (rtos (car p) 2 4) "," (rtos (cadr p) 2 4) "," (rtos (caddr p) 2 4) ) ) ) ) (setq fin 1) ;; set for *error* region restore if crash/bad.stop (setq cec (getvar 'cecolor)) ;; save color to restore to (setvar 'nomutt 1) ;; bypass ssget 'select prompt (if (setq ss (ssget ":S" '((0 . "REGION")))) ;; select 1 region for osnap/coords (progn (command "_.copybase" "0,0,0" ss "") ;; copy region to clipbrd (command "chprop" ss "" "c" 142 "") ;; change seg's color (setq LastEnt (entlast)) ;; ;;; !!!!!!!!!!!!!!!! ;; mhupp A1 to make exploded region (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (command "_.explode" ss) ;; make segs accessable, saved in 'ss to erase (setq SS1 (ssadd)) ;; create a blank selection set or add to an existing one., saved in 'SS1 to erase (while (setq LastEnt (entnext LastEnt)) ;; (ssadd LastEnt SS1) ;; ) (princ "\nSelect Vertex(s) to add POint: <no.resist> ") (initget 1) ) ;; end of progn ) ;; end of if (while ;; pick points loop <cancel to end picking> (setq p (getpoint)) (entmakex (list (cons 0 "POINT") (cons 10 p))) ;; clean point (princ "\n") (ftp) ;; post coords ) (setvar 'nomutt 0) (sssetfirst nil ss1) ;;temp entity highlight (redraw) ;; <- usually required to show.. (ddelay 4e-7); ;; seems to allow 'short.times' <larger #'s = longer> BIGAL (sssetfirst nil nil) ;; <--- deselect above 'sssetfirst' (command "_.erase" ss "") ;; region copied/erasure (command "_.erase" ss1 "") ;; erases exploded region (command "chprop" "_L" "" "c" "bylayer" "") ;; ch copied to bylayer (command "_.pasteclip" "0,0,0") ;; re.place original region ? <- safe.r way ?? (setq fin nil) ;; reset if complete (princ "\nCleaned.Up ") (setvar 'cecolor "bylayer") ;; ch current color to bylayer (setvar 'nomutt 0) (setvar 'cmdecho 1) (*error* nil) (princ) ) Quote
ScottMC Posted 1 hour ago Author Posted 1 hour ago Here's my latest region segment copier.. (defun TLENGTH (/ di ent n pt1 pt2 sel) ;; https://ukcommunity.arkance.world/hc/en-us/articles/21550748461458-AutoCAD-Tip-Using-AutoLisp-to-calculate-total-length-of-multiple-objects (vl-load-com) ;; NotLoaded/Patrick_35/Tot-v1.03 ; (if (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE"))) (progn (setq di 0) (vlax-for ent (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))) (cond ((member (vla-get-objectname ent) '("AcDbLine")) ;; "AcDb3dPolyline" "AcDbPolyline" (setq di (+ di (vla-get-Length ent))) ;; <- not a2k op for /\ poly?? ) ((eq (vla-get-objectname ent) "AcDbArc") (setq di (+ di (vla-get-ArcLength ent))) ) ((eq (vla-get-objectname ent) "AcDbCircle") (setq di (+ di (vla-get-Circumference ent))) ) ((member (vla-get-objectname ent) '("AcDbSpline" "AcDbEllipse")) (setq di (+ di (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)))) ) ) ) ) (princ (strcat (rtos di 2 4) " :Len")) (princ) ) ;;// ----------------------------------------------------------------------------------------------------------- (defun c:crs (/ *error* ss ss1 ssm ssp cec doc lastent html) ;; AI.. https://www.google.com/search?q=copy+region+edge+segment%2C+autolisp&client=firefox-b-1-e&hs=LJSp&sca_esv=28d160b4388e87a1&biw=1143&bih=530&ei=t2enadf8OfXIp84PyJ69kA8&ved=0ahUKEwiXtPqy6oSTAxV15MkDHUhPD_I4ChDh1QMIEQ&uact=5&oq=copy+region+edge+segment%2C+autolisp&gs_lp=Egxnd3Mtd2l6LXNlcnAiImNvcHkgcmVnaW9uIGVkZ2Ugc2VnbWVudCwgYXV0b2xpc3AyCBAAGIAEGKIEMgUQABjvBTIFEAAY7wUyBRAAGO8FMgUQABjvBUjeM1C3D1iRLnABeACQAQCYAYgIoAHMC6oBBzAuNC43LTG4AQPIAQD4AQGYAgagApcNwgIIEAAYsAMY7wXCAgoQIRigARjDBBgKmAMAiAYBkAYFkgcHMS40LjYtMaAH0BCyBwcwLjQuNi0xuAffDMIHBzItMS4zLjLIB2uACAA&sclient=gws-wiz-serp (princ "\n ** wcs Copy Region Segment: <oops> ") ;; https://www.cadtutor.net/forum/topic/99013-segment-copy-of-a-region-cleaning-request/#findComment-678508 (setvar 'cmdecho 0) (vl-load-com) ;; (defun *error* ( msg ) (setvar 'cmdecho 0) ;; (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) (if msg (prompt (strcat "\n" msg))) (if (= fin 1) (command "_.pasteclip" "0,0,0")) ;; restores region if incomplete/esc.. (setvar 'cecolor cec) ;; ch copied to prev (setvar 'cursorsize 100) (setvar 'osmode posm) (setvar 'nomutt 0) (setvar 'cmdecho 1) (princ) ) (setq posm (getvar 'osmode)) ;; better without end/with.nea (setvar 'osmode (boole 7 (getvar 'osmode) 512)) ;; adds <nea> (setvar 'osmode (boole 2 (getvar 'osmode) 1)) ;; removes <end> (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) ;; eases oops's/undo ;; clears clipbrd Roy_043;; https://www.cadtutor.net/forum/topic/62075-copy-to-clipboard/#findComment-512255 (setq html (vlax-create-object "HTMLFile")) (vlax-invoke (vlax-get (vlax-get html 'ParentWindow) 'ClipboardData) 'SetData "Text" "") (vlax-release-object html) (setq fin 1) (setq cec (getvar 'cecolor)) (setvar 'nomutt 1) ;; bypass ssget 'select prompt ;;// ----------------------------------------------------------------------------------------------------------- ;; init selection (while ;; loop/proof/select 1 region (not (setq ss (ssget ":S" '((0 . "REGION"))))) ) (command "_.copybase" "0,0" ss "") ;; copy region to clipbrd (command "chprop" ss "" "c" 142 "") ;; change color (setq LastEnt (entlast)) ;; Set LastEnt to last entity.;;; !! beginning of entity storage \/ (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (command "_.explode" ss) ;; make segs accessible (setq SS1 (ssadd)) ;; create a blank selection set 'SS1 for later use ;; or add to an existing one., (while (setq LastEnt (entnext LastEnt)) ;; Sets LastEnt to first entity name (ssadd LastEnt SS1) ;; adds LastEnt to new 'SS1 selection set, to erase later !! ) (while T ;; loop to multi-copy of exploded region.. <actually anything> (princ "\nSelect Region Segment to Copy ") (setvar 'cursorsize 1) ;; get cursor.lines out.of.site (initget 1) ;; added to filter but, 'rt.clk < pastes but as.from base zero > ;; usable (defun loop ( / ) ;; select.validator (and ;; when ssp+ssm happen.. (setq ssp (getpoint)) ;; get coords for copy/basepoint <----------------------- (if (not (setq ssm (ssget ssp '((0 . "*POLYLINE,ARC,CIRCLE,LINE,ELLIPSE"))))) ;; pick on segment [at 'ssp] (progn (princ "\rSelect Region Segment to Copy ")(loop)) ) ;; /\ NOT CATCHING: ITEMS.NOT.FROM.'EXPLODE' () ;; BUT STILL FUNCTIONS [COPIES] ANY.. ) ;; end of and ) ;; end of if (loop) ;; restart if not 'ssp type or open pic /\ (command "_.copy" ssm) ;; begin move a segment copy (setvar 'nomutt 1) ;; manual prompt (command "" ssp) ;; coords selected in /\ 'loop removed: (princ "\nSpecify Basepoint: ") (command "" "\\") (princ "\nSpecify Destination: ") (command "\\") ;; +move to (setvar 'nomutt 0) ;; turn prompt on (TLENGTH) (command "chprop" "_L" "" "c" cec "") ;; ch copied color to bylayer ) ;; end of while loop (setvar 'cursorsize 100) ;; set 'cross.hair.size' to normal (setvar 'nomutt 0) ;; turn prompt on (command "_.erase" ss "") ;; region copied/erasure (command "_.erase" SS1 "") ;; erases exploded (saved) selection set -|100 ; moved within while /\ (command "chprop" "_L" "" "c" cec "") ;; ch copied color to bylayer (command "_.pasteclip" "0,0") ;; re.places original copied region -|86 (setq fin nil) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) ;; eases oops's/undo (setvar 'cecolor cec) ;; resets color (setvar 'cursorsize 100) (setvar 'osmode posm) (setvar 'nomutt 0) (setvar 'cmdecho 1) (*error* nil) (princ) ) Quote
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.