块实体转成组

Lisphk

[XML] 纯文本查看 复制代码

(defun c:b2r (/ _ss2list vk_creategroup ce h ss ss2 qa)
  (defun vk_creategroup (name entslist selflag / groupdic entname)
    (if (and entslist
             (setq groupdic (cdadr (member (cons 3 "ACAD_GROUP") (entget (namedobjdict)))))
             ;; RJP changed vl-position to member since OP needs vanilla lisp
             (not (and name (member (cons 3 name) (entget groupdic))))
             (setq entname (entmakex (append (list (cons 0 "GROUP")
                                                   (cons 100 "AcDbGroup")
                                                   (cons 300 "")
                                                   (cons 70
                                                         (if name
                                                           0
                                                           1
                                                         )
                                                   )
                                                   (cons 71 selflag)
                                             )
                                             (mapcar (function (lambda (e) (cons 340 e))) entslist)
                                     )
                           )
             )
             (entmod (append (entget groupdic)
                             (list (cons 3
                                         (if (null name)
                                           "*"
                                           name
                                         )
                                   )
                                   (cons 350 entname)
                             )
                     )
             )
        )
      (if name
        name
        (cdadr (member (cons 350 entname) (reverse (entget groupdic))))
      )
    )
  )
  (defun _ss2list (ss / n out)
    (if (= (type ss) 'pickset)
      (repeat (setq n (sslength ss)) (setq out (cons (ssname ss (setq n (1- n))) out)))
    )
  )
  (if (setq ss (_ss2list (ssget ":L" '((0 . "insert")))))
    (progn (setq ce (getvar 'cmdecho))
           (setq qa (getvar 'qaflags))
           (setvar 'cmdecho 0)
           (setvar 'qaflags 0)
           (foreach e ss
             (setq h (cdr (assoc 5 (entget e))))
             (command "_.explode" e)
             (if (setq ss2 (_ss2list (ssget "_P")))
               (vk_creategroup h ss2 1)
             )
           )
           (setvar 'cmdecho ce)
           (setvar 'qaflags qa)
    )
  )
  (princ)
)

sicky111

沙发，支持楼主。

panliang9

明经G版写的，然后飞诗又稍作调整，块转组，组变块，可以变来变去！
;;;*************函数 gxl-massoc.lsp  *************
;;;==================================================================
;;;gxl-massoc 返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
;|功能
返回包含每一出现在列表中的指定键的cdr(点对的后部分)的列表。
参数
一个整数和一个图元定义列表
示例
(gxl-massoc 10 (entget (car (entsel))))
注意
该函数特别适合用于找到细多义线上的所有顶点。
|;
;;;==================================================================
(defun gxl-massoc (key alist)
  (mapcar 'cdr
          (vl-remove-if-not '(lambda (x) (equal key (car x))) alist)
  )
)
;;;***************** 函数 gxl-massoc*****************


;;;*************函数 gxl-grp-getgroupentities.lsp  *************
;; | ----------------------------------------------------------------------------
;; | (gxl-grp-GetGroupEntities 组的图元名)由组的图元名返回组成员
;; | ----------------------------------------------------------------------------
;; | 功能 : 查找组成员
;; | 参数 : 'ename' - ACAD_GROUP词典内组的图元名
;; | Action   : 返回组成员的图元列表
;; | ----------------------------------------------------------------------------
;;(gxl-grp-GetGroupEntities (caadr (gxl-grp-GetAllGroups)))
(defun gxl-grp-GetGroupEntities        (ename)
  (gxl-MASSOC 340 (entget ename))
)
;;;***************** 函数 gxl-grp-GetGroupEntities*****************


;;;*************函数 gxl-getssbox.lsp  *************

;; gxl-GetssBox 取得选择集的实体外矩形框/
(defun gxl-GetssBox (ss / i l1 l2 ll ur)
  (repeat (setq i (sslength ss))
    (vla-getboundingbox
      (vlax-ename->vla-object (ssname ss (setq i (1- i))))
      'll
      'ur
    )
    (setq l1 (cons (vlax-safearray->list ll) l1)
          l2 (cons (vlax-safearray->list ur) l2)
    )
  )
  (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
          '(min max)
          (list l1 l2)
  )
)
;;;***************** 函数 gxl-GetssBox*****************


;;;*************函数 gxl-blk-makeunnameblock.lsp  *************

;;;===================================================================
;;;gxl-BLK-MakeUnNameBlock 生成无名图块
;|功能
生成无名图块
参数
ss：选择集
返回值
无名块
示例
(gxl-BLK-MakeUnNameBlock (ssget))
注意
函数对选择集中存在具有属性的图块及复杂多义线无效
|;
;;;===================================================================
(defun gxl-BLK-MakeUnNameBlock (ss / count entlist ent blk pt)
  (setq pt (car (gxl-GetssBox ss)))
  (entmake (list '(0 . "BLOCK")
                 '(2 . "*U")
                 '(70 . 1)
                 (cons 10 pt)
           )
  )
  (setq count 0)
  (repeat (sslength ss)
    (setq entlist (entget (setq ent (ssname ss count))))
    (setq count (1+ count))
    (entmake entlist)
  )
  (setq count 0)
  (repeat (sslength ss)
    (setq ent (ssname ss count))
    (setq count (1+ count))
    (entdel ent)
  )
  (setq blk (entmake '((0 . "ENDBLK"))))
  (if (princ blk)
    (entmake (list (cons 0 "INSERT")
                   (cons 2 blk)
                   (cons 10 pt)
             )
    )
  )
  blk
)
;;(makeNameBlock ss)
(defun makeNameBlock (ss)
  (setq name (strcat (rtos (getvar "cdate") 2 8) (itoa i)))
  (setq i (1+ i))
  (command "-BLOCK" name "non" '(0 0) ss "")
  (command ".insert" name "non" '(0 0) "" "" "")
)
;;;***************** 函数 gxl-BLK-MakeUnNameBlock*****************


;;;*************函数 gxl-sel-mapcar.lsp  *************
;;;(gxl-Sel-Mapcar ss Fun) 遍历选择集对所包含的图元进行指定函数操作,返回操作后的表
(defun gxl-Sel-Mapcar (ss Fun / nn rtn)
  (if ss
    (repeat (setq nn (sslength ss))
      (setq rtn
             (cons (apply Fun (list (ssname ss (setq nn (1- nn))))) rtn)
      )
    )
  )
)
;;;***************** 函数 gxl-Sel-Mapcar*****************


;;;*************函数 gxl-grp-memberofgroup.lsp  *************
;; | ----------------------------------------------------------------------------
;; | (gxl-grp-MemberOfGroup ename) 由图元返回所属的组图元名
;; | ----------------------------------------------------------------------------
;; | 功能 : 查找物件所归属的ACAD_GROUP组的图元名
;; | 参数 : 'ename' -  AutoCAD 图形 图元名
;; | 返回值 : 由组名返回ACAD_GROUP词典内组的图元名
;; | 提示  : 参数 'ename' 可以是图元名，也可以是由entget返回的列表
;; | ----------------------------------------------------------------------------
                                        ;  (gxl-grp-MemberOfGroup (car (entsel)))

(defun gxl-grp-MemberOfGroup (ename / GrpLst GroupEname)

  (setq GroupEname nil)
  (if ename
    (if        (listp ename)
      (setq GroupEname (gxl-MASSOC 330 ename))
      (setq GroupEname (gxl-MASSOC 330 (entget ename)))
    )
  )
  (reverse (cdr (reverse GroupEname)))
)
;;;***************** 函数 gxl-grp-MemberOfGroup*****************


;;;*************函数 gxl-delsame.lsp  *************
(defun gxl-delsame (l)
  (if L
    (cons (car L) (gxl-delsame (vl-remove (car L) (cdr L))))
  )
)
;;;***************** 函数 gxl-delsame*****************
(defun gxl-Sel-List->SS        (Lst / en ss kk)
  (setq        ss (ssadd)
        kk 0
  )
  (foreach en Lst
    (ssadd en ss)
    (setq kk (1+ kk))
  )
  ss
)

;;;*************************************************
(defun b2g (blk / bname)
  (setq bname (cdr (assoc 2 (entget blk))))
  (command "._undo"
           "_begin"
           "._explode"
           blk
           "._-group"
           "_create"
           "*"
           (strcat "explode:" bname)
           (ssget "p")
           ""
           "._undo"
           "_end"
  )
)
(defun g2b (grpename)
  (setq ss (gxl-SEL-LIST->SS (gxl-grp-GetGroupEntities grpename)))
  (makeNameBlock ss)
)
;;块==>组
(defun c:ggg (/ s cmdecho)
  (setq cmdecho (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setq s (ssget ":L" '((0 . "insert"))))
  (if s
    (gxl-SEL-MAPCAR s 'b2g)
  )
  (setvar 'cmdecho cmdecho)
  (princ)
)
;;组==>块
(defun c:bbb (/ s grpl cmdecho i)
  (setq cmdecho (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setq s (ssget ":L"))
  (setq grpl (apply 'append (gxl-SEL-MAPCAR s 'gxl-grp-MemberOfGroup)))
  (setq grpl (gxl-delsame grpl))
  (setq i 1)
  (mapcar 'g2b grpl)
  (setvar 'cmdecho cmdecho)
  (princ)
)
(princ
  "\n块==>组 命令:ggg 组==>块 命令: bbb  Gu_xl 2012.04.17"
)
(princ)