Replace circle by block

[manirpg]

Hi friends,

Is there any lisp to replace selected circles by block............

pls help me

Thanks

mani

[VVA]

Try it

;;; Command changes the set of primitives for the selected primitive. 
;;; Examples: 
;;; Replacement of some other blocks. 
;;; Replacement blocks or dots circles. 
;;; Replacement of some other titles. 
;;; 
;;; First you need to select a sample, and then specify replaceable objects.
;;; Box is in the center is restricted (bounding) rectangle of old objects.
;;; New objects are inserted into the layers that Belonged to which the old objects. 
;;; Supports pre-selection.

(defun c:frto(/ ACTDOC COPOBJ ERRCOUNT EXTLST
      EXTSET FROMCEN LAYCOL MAXPT CURLAY
      MINPT OBJLAY OKCOUNT OLAYST
      SCLAY TOCEN TOOBJ VLAOBJ *ERROR* ASK)
 (vl-load-com)
 (defun *ERROR*(msg)
   (if olaySt (vla-put-Lock objLay olaySt)); end if
   (vla-EndUndoMark actDoc)(princ)); end of *ERROR*

 (defun GetBoundingCenter(vlaObj / blPt trPt cnPt)
 (vla-GetBoundingBox vlaObj 'minPt 'maxPt)
     (setq blPt(vlax-safearray->list minPt)
     trPt(vlax-safearray->list maxPt)
     cnPt(vlax-3D-point
     (list
           (+(car blPt)(/(-(car trPt)(car blPt))2))
           (+(cadr blPt)(/(-(cadr trPt)(cadr blPt))2))
           (+(caddr blPt)(/(-(caddr trPt)(caddr blPt))2)) ;_<<< Заменили
           )))); end of GetBoundingCenter
 (setq extSet(ssget "_I"))
(while (not (setq toObj(entsel "\n+++ Select source object (sample) -> ")))
  (princ "\nSource objects isn't selected!"))
 (if(not extSet)
   (progn
     (princ "\n+++ Select destination (replaceable) objects and press Enter <- ")
     (setq extSet(ssget "_:L")))); end if
 (if(not extSet)(princ "\nDestination objects isn't selected!")); end if
 (if (and extSet toObj)
   (progn
     (initget "Yes No")
     (setq ask (getkword "\nRemove destination object [Yes/No] <No>:"))
     (setq actDoc (vla-get-ActiveDocument(vlax-get-Acad-object))
     layCol (vla-get-Layers actDoc)
     extLst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp
                    (mapcar 'cadr(ssnamex extSet))))
     vlaObj (vlax-ename->vla-object(car toObj))
     objLay (vla-Item layCol (vla-get-Layer vlaObj))
     olaySt (vla-get-Lock objLay)
    fromCen (GetBoundingCenter vlaObj)
     errCount 0  okCount 0); end setq
     (vla-StartUndoMark actDoc)
     (foreach obj extLst
       (setq toCen (GetBoundingCenter obj)
             scLay (vla-Item layCol (vla-get-Layer obj)));end setq
 (if(/= :vlax-true(vla-get-Lock scLay))
   (progn
   (setq curLay(vla-get-Layer obj))
   (vla-put-Lock objLay :vlax-false)
   (setq copObj(vla-copy vlaObj))
   (vla-Move copObj fromCen toCen)
   (_kpblc-ent-properties-copy obj copObj)
   (vla-put-Layer copObj curLay)
   (vla-put-Lock objLay olaySt)
   (if (= ask "Yes")(vla-Delete obj))
   (setq okCount(1+ okCount))
   ); end progn
   (setq errCount(1+ errCount))
   ); end if
 ); end foreach
     (princ (strcat "\n" (itoa okCount) " were changed. "
   (if(/= 0 errCount)(strcat (itoa errCount) " were on locked layer! ")  "")))
     (vla-EndUndoMark actDoc)); end progn
   (princ "\nSource object isn't selected! ")
   ); end if
 (princ)); end of c:frto
(defun _kpblc-ent-properties-copy (source dest)
(foreach prop   '("Angle" "Layer" "Linetype" "LinetypeScale" "Lineweight"
       "Normal" "PlotStyleName" "Thickness" "Color" "Visible"
       "Closed" ;|"ConstantWidth" ; не копируется|; "Elevation" "LinetypeGeneration"
       "LinetypeScale" ;|"StartAngle" "EndAngle" ; не копируются|; "Alignment"
       "Backward" "Height" "ObliqueAngle" "Rotation" "ScaleFactor" "StyleName"
       "TextGenerationFlag"  "TextHeight"  "UpsideDown"  "AttachmentPoint" "BackgroundFill"
       "DrawingDirection"  "LineSpacingDistance" "LineSpacingFactor" "LineSpacingStyle"  "Width"
       "XScaleFactor" "YScaleFactor" "ZScaleFactor" ;| Viewport|; "ArcSmoothness" "CustomScale"
       "Direction" "DisplayLocked"  "GridOn" "LensLength" "ModelView" "ShadePlot" "SheetView"
       "SnapBasePoint" "SnapOn" "SnapRotationAngle" "StandardScale" "Target"  "TwistAngle"
       "UCSIconAtOrigin"   "UCSIconOn"     "UCSPerViewport" "ViewportOn")
(if (and (vlax-property-available-p source prop)(vlax-property-available-p dest prop t))
 (vl-catch-all-apply
   '(lambda ()(vlax-put-property dest prop (vlax-get-property source prop))))
  )
  )
 )

First select block, then select circles

[Lee Mac]

Another

 

(defun c:cir2ins ( / blk ss )  
 ;; © Lee Mac 2010

 (if
   (and
     (setq blk
       (LM:SelectifFoo
         (lambda ( x )
           (and (eq "INSERT" (cdr (assoc 0 (entget x))))
             (zerop
               (logand (+ 1 4)
                 (cdr
                   (assoc 70
                     (tblsearch "BLOCK"
                       (cdr
                         (assoc 2
                           (entget x)
                         )
                       )
                     )
                   )
                 )
               )
             )
           )
         )
         "\nSelect Block: "
       )
     )
     (setq ss (ssget "_:L" '((0 . "CIRCLE"))))
   )
   (
     (lambda ( i / e )
       (while (setq e (ssname ss (setq i (1+ i))))
         (if
           (entmakex
             (append
               (list
                 (cons 0 "INSERT")
                 (assoc 2 (entget blk))
               )
               (LM:RemovePairs '(0 100 40) (entget e))
             )
           )
           (entdel e)
         )
       )
     )
     -1
   )
 )
 (princ)
)

   
(defun LM:SelectifFoo ( foo str / sel ent )
 (vl-load-com)
 ;; © Lee Mac 2010
 (while
   (progn
     (setq sel (entsel str))
     
     (cond
       (
         (vl-consp sel)

         (if (not (foo (setq ent (car sel))))
           (princ "\n** Invalid Object Selected **")
         )
       )
     )
   )
 )
 ent
)
                 
(defun LM:RemovePairs ( pairs lst )
 (vl-load-com)
 ;; © Lee Mac 2010
 (vl-remove-if
   (function
     (lambda ( pair )
       (vl-position (car pair) pairs)
     )
   )
   lst
 )
)

[manirpg]

Thanks VVA and LEE

Both of the codes working nice.....it will help me lot.........

Thanking you

 

Regards

mani:):)

[Lee Mac]

You're very welcome Mani

[waikatosteve]

Hi Lee,

just wondering how you would change this to replace donuts?

I tried modifing the code, but cant get it to work properly.

 

Thanks

Steve

[MSasu]

Donut isn't a type of entity; the DONUT command will generate thick polylines made by two arcs. So, you need to design an algorithm to recognize them. Will have to validate that the arcs share the same center point, were connected at ends and their inside angles were 180 degrees (DXF code 42 is set to 1.0 - this ensure also that the arcs were parsed in the same sense, so were not coincident).

[Stefan BMR]

Hi Lee,

just wondering how you would change this to replace donuts?

I tried modifing the code, but cant get it to work properly.

 

Thanks

Steve

You can covert donuts to circles via Express Tools - overkill.

Then run Lee's code.

 

Or try this to replace donuts:

(defun C:TEST ( / ss b)
 (and
   (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 2) (70 . 1))))
   (setq b (getstring "\nBlock name: "))
   (tblsearch "BLOCK" b)
   (donut->block ss b)
   )
 (princ)
 )


(defun donut->block (ss b / i e r l p)
 (repeat
   (setq i (sslength ss))
    (setq e (entget (ssname ss (setq i (1- i))))
          r (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 42)) e))
          )
    (if
      (or
       (equal r '( 1.0  1.0) 1e-10)
       (equal r '(-1.0 -1.0) 1e-10)
       )
      (progn
        (setq l (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) e))
              p (list (* 0.5 (+ (caar l) (caadr l)))
                      (* 0.5 (+ (cadar l) (cadadr l)))
                      (cdr (assoc 38 e))
                )
        )
        (entmake
          (list
           '(0 . "INSERT")
            (cons 2 b)
            (cons 10 p)
            (assoc 210 e)
            )
          )
        (entdel (cdr (assoc -1 e)))
      )
    )
  )
 (princ)
)

[waikatosteve]

Thanks very much Stefan, that works fantastic!

 

Cheers

Steve

[Stefan BMR]

You are welcome Steve. I'm glad you like it.

[stretch5544]

Hi All,

 

I am new to this forum. I have been looking for a lisp routine that could select all circles of a specific diameter not a range or greater than/ less than scenario on any layer and replace them with a block reference then delete the original circle. Lee's code works well however i want to do a bulk selection and replacement not select each individual circle to be replaced. A counter to display how many circles have been replaced would be beneficial however not necessary. Can anyone help me?

[BIGAL]

stretch5544 if you look at the code above

 

(setq ss (ssget "_:L" '((0 . "CIRCLE")))) this selects a circle

(ssget "X" '((0 . "CIRCLE")))) will look through out the dwg and find all circles

(setq ss (ssget "X" '((0 . "CIRCLE")(cons 40 rad)))) will get all circles with a radius of rad

 

Start with lee's code above

[stretch5544]

Thanks BIGAL and Lee. Much appreciated. I will try that today and let you know how it goes.

[jason turner]

Hi guys. Thanks for that LISP. It is exactly what I wanted. But I cannot see the command code to get it started.

Thanks

Jason

[SLW210]

Which LISP are you using?

 

It will be the part following the (defun C:)

[jason turner]

Thank you, Moderator. That works

 

Out of interest, I could not get the second version to work. It simply deleted all of the circle.

JT