[编程交流] 从dr创建块的Lsp

(defun c:setnb (/ ss adoc pt_lst center blk *error* bi bname bpat)
;;;Selected Entities To Named Block
 (setq bpat "BLOCK-") ;_ <- Edit block name pattern here
 (defun *error* (msg)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun
 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-StartUndoMark
 (if (not (vl-catch-all-error-p
            (vl-catch-all-apply '(lambda () (setq ss (ssget "_:L"))))
            ) ;_ end of vl-catch-all-error-p
          ) ;_ end of not
   (progn
     (setq
       ss     (mapcar 'vlax-ename->vla-object
                      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                      ) ;_ end of mapcar
       pt_lst (apply 'append
                     (mapcar
                       '(lambda (x / minp maxp)
                          (vla-getboundingbox x 'minp 'maxp)
                          (list (vlax-safearray->list minp)
                                (vlax-safearray->list maxp)
                                ) ;_ end of append
                          ) ;_ end of lambda
                       ss
                       ) ;_ end of mapcar
                     ) ;_ end of append
       center (mapcar '(lambda (a b) (/ (+ a b) 2.))
                      (list (apply 'min (mapcar 'car pt_lst))
                            (apply 'min (mapcar 'cadr pt_lst))
                            (apply 'min (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      (list (apply 'max (mapcar 'car pt_lst))
                            (apply 'max (mapcar 'cadr pt_lst))
                            (apply 'max (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      ) ;_ end of mapcar
       bname
       (progn
         (setq bi 0)
         (while (tblsearch "BLOCK" (setq bname (strcat bpat (itoa(setq bi(1+ bi)))))))
            bname)
       blk    (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point center)
                       bname
                       ) ;_ end of vla-add
       ) ;_ end of setq
     (vla-copyobjects
       adoc
       (vlax-make-variant
         (vlax-safearray-fill
           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss))))
           ss
           ) ;_ end of vlax-safearray-fill
         ) ;_ end of vlax-make-variant
       blk
       ) ;_ end of vla-copyobjects
     (vla-insertblock
       (vla-objectidtoobject adoc (vla-get-ownerid (car ss)))
       (vlax-3d-point center)
       (vla-get-name blk)
       1.0
       1.0
       1.0
       0.0
       ) ;_ end of vla-insertblock
     (mapcar 'vla-erase ss)
     ) ;_ end of and
   ) ;_ end of if
 (vla-endundomark adoc)
 (princ)
 ) ;_ end of defun
(defun c:SETNB1 (/ ss adoc pt_lst center blk *error* lst bpat bname bi)
 ;;;Each primitive in a separate named block
 ;;;Каждый примитив в отдельный Имсенованный блок
 (defun *error* (msg)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun
 (setq bpat "BLOCK-") ;_ <- Edit block name pattern here
 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-StartUndoMark
 (if (not (vl-catch-all-error-p
            (vl-catch-all-apply '(lambda () (setq ss (ssget "_:L"))))
            ) ;_ end of vl-catch-all-error-p
          ) ;_ end of not
   (progn
     (mapcar '(lambda(item)
     (setq
ss (list item)
       pt_lst (apply 'append
                     (mapcar
                       '(lambda (x / minp maxp)
                          (vla-getboundingbox x 'minp 'maxp)
                          (list (vlax-safearray->list minp)
                                (vlax-safearray->list maxp)
                                ) ;_ end of append
                          ) ;_ end of lambda
                       ss
                       ) ;_ end of mapcar
                     ) ;_ end of append
       center (mapcar '(lambda (a b) (/ (+ a b) 2.))
                      (list (apply 'min (mapcar 'car pt_lst))
                            (apply 'min (mapcar 'cadr pt_lst))
                            (apply 'min (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      (list (apply 'max (mapcar 'car pt_lst))
                            (apply 'max (mapcar 'cadr pt_lst))
                            (apply 'max (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      ) ;_ end of mapcar
       bname
       (progn
         (setq bi 0)
         (while (tblsearch "BLOCK" (setq bname (strcat bpat (itoa(setq bi(1+ bi)))))))
            bname)
       blk    (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point center)
                       bname
                       ) ;_ end of vla-add
       ) ;_ end of setq
     (vla-copyobjects
       adoc
       (vlax-make-variant
         (vlax-safearray-fill
           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss))))
           ss
           ) ;_ end of vlax-safearray-fill
         ) ;_ end of vlax-make-variant
       blk
       ) ;_ end of vla-copyobjects
     (vla-insertblock
       (vla-objectidtoobject adoc (vla-get-ownerid (car ss)))
       (vlax-3d-point center)
       (vla-get-name blk)
       1.0
       1.0
       1.0
       0.0
       ) ;_ end of vla-insertblock
         )
  (setq
       lst     (mapcar 'vlax-ename->vla-object
                      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                      ) ;_ end of mapcar
)
      )
     
     (mapcar 'vla-erase lst)
     ) ;_ end of and
   ) ;_ end of if
 (vla-endundomark adoc)
 (princ)
 )

(defun c:sm (/ ERRCOUNT MAXPT MINPT MIPT MNPT MXPT 
         OBJSET PTLST XLST YLST old Flg) 
(vl-load-com) 
 (if(not sm:scale)(setq sm:scale 1)) 
   (initget 6)    
   (setq old sm:scale 
         sm:scale(getdist 
        (strcat"\nSpecify the scale factor <"(rtos sm:scale 2 2)">: ")) 
  ); end setq 
 (if(null sm:scale)(setq sm:scale old)) 
 (setq errCount 0 ptLst 'nil Flg t); en setq 
 (while Flg 
   (princ "\n§§§ Select objects and press Enter or Esc to exit. §§§") 
(if 
  (not(setq objSet(ssget "_I"))) 
  (setq objSet(ssget)) 
  ); end if 
 (if objSet 
   (progn 
     (setq objSet 
      (mapcar 'vlax-ename->vla-object 
                   (vl-remove-if 'listp 
                    (mapcar 'cadr(ssnamex objSet))))) 
     (foreach obj objSet 
  (vla-GetBoundingBox obj 'MinPt 'MaxPt) 
   (setq mnPt(vlax-safearray->list MinPt) 
    mxPt(vlax-safearray->list MaxPt) 
    miPt (polar mnPt (angle mnPt mxPt)(* 0.5 (distance mnPt mxPt)))      
    )
    (if (vlax-method-applicable-p obj 'ScaleEntity)
    (if 
     (vl-catch-all-error-p 
  (vl-catch-all-apply 'vla-ScaleEntity 
    (list obj(vlax-3D-Point miPt) sm:scale))) 
     (setq errCount(1+ errCount)) 
     )
      )
  ); end foreach 
  (princ(strcat "\n" (itoa errCount) " objects blocked layer! ")) 
  ) 
     ); if objset 
   (setq Flg nil) 
 ); end while 
 )

(defun c:SETNB2 (/ ss adoc pt_lst center blk *error* lst bpat bname bi first)
 ;;;Each primitive in a separate named block
 ;;;http://www.cadtutor.net/forum/showthread.php?p=287449&posted=1#post287449
 (defun *error* (msg)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun
 (setq bpat "BLOCK-") ;_ <- Edit block name pattern here
 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-StartUndoMark
 (if (not (vl-catch-all-error-p
            (vl-catch-all-apply '(lambda () (setq ss (ssget "_:L"))))
            ) ;_ end of vl-catch-all-error-p
          ) ;_ end of not
   (progn
     (mapcar '(lambda(item)
     (setq
ss (list item)
       pt_lst (apply 'append
                     (mapcar
                       '(lambda (x / minp maxp)
                          (vla-getboundingbox x 'minp 'maxp)
                          (list (vlax-safearray->list minp)
                                (vlax-safearray->list maxp)
                                ) ;_ end of append
                          ) ;_ end of lambda
                       ss
                       ) ;_ end of mapcar
                     ) ;_ end of append
       center (mapcar '(lambda (a b) (/ (+ a b) 2.))
                      (list (apply 'min (mapcar 'car pt_lst))
                            (apply 'min (mapcar 'cadr pt_lst))
                            (apply 'min (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      (list (apply 'max (mapcar 'car pt_lst))
                            (apply 'max (mapcar 'cadr pt_lst))
                            (apply 'max (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      ) ;_ end of mapcar
)
(if (null first)
  (progn
    (setq
      bname  
     (progn
       (setq bi 0)
       (while (tblsearch "BLOCK" (setq bname (strcat bpat (itoa(setq bi(1+ bi)))))))
       bname)
      blk
     (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point center)
                       bname
              )
      ) ;_ end of setq
   (vla-copyobjects
       adoc
       (vlax-make-variant
         (vlax-safearray-fill
           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss))))
           ss
           ) ;_ end of vlax-safearray-fill
         ) ;_ end of vlax-make-variant
       blk
       );_ end of vla-copyobjects
    (setq first t)
  )
)
    
     (vla-insertblock
       (vla-objectidtoobject adoc (vla-get-ownerid (car ss)))
       (vlax-3d-point center)
       (vla-get-name blk)
       1.0
       1.0
       1.0
       0.0
       ) ;_ end of vla-insertblock
         )
  (setq
       lst     (mapcar 'vlax-ename->vla-object
                      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                      ) ;_ end of mapcar
)
      )
     
     (mapcar 'vla-erase lst)
     ) ;_ end of and
   ) ;_ end of if
 (vla-endundomark adoc)
 (princ)
 )