[编程交流] 按块替换圆

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

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