Segment Copy of a Region (cleaning request)

[ScottMC]

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 12 hours ago by ScottMC
..

[mhupp]

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)
)

     

[marko_ribar]

If I understood you correctly, you are searching to something like this...

 

(defun c:copy_reg_edg ( / *error* car-sort osm 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 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)
  (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 "_.copy" edg "" "_non" (trans ptt 0 1) "\\")
          (entdel edg)
        )
        (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 "_.copy" ss "" "_non" (trans ptt 0 1) "\\")
          (vl-cmdf "_.erase" ss "")
        )
      )
    )
    (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 47 minutes ago by marko_ribar

[ScottMC]

PURRRFECT!

Thanks so much 'mhupp

This gets me all.the.more excited to learn more!

[ScottMC]

Marco, when'd u write that?

let me try it...  seems to refuse

arc segs but do like your select

style

Edited 2 hours ago by ScottMC

[marko_ribar]

I tested it under AutoCAD 2022 and BricsCAD V26 and it worked well and with arced segments...

Do you receive some error messages?

[ScottMC]

(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