感谢G版再次出手相助！为什么不能删除块中WIPEOUT实体呢？

smartstar · 发表于 2012-6-20 14:53:06

本帖最后由 smartstar 于 2012-6-29 12:53 编辑

下面程序哪里有问题，为什么不能删除块中WIPEOUT实体呢？
(defun c:111 ()
 (defun GRP (GCC EL) (cdr (assoc GCC EL)))
 (setq BlkEntName (car (entsel)))
 (setq Blist (ayGetAllEntInBLK BlkEntName))
 (setq n 0)
 (while (< n (length Blist))
(setq ENAME (nth n Blist))
(if (= "WIPEOUT" (GRP 0 (entget ENAME)))
 (entdel ENAME)
)
(setq n (1+ n))
 )
 (princ)
)
;;;以下是晓城的子程,写的非常棒!!
;;;普通浏览复制代码
;;;***********************************************************
;;; No.1-2 获取图块内的所有非图块对象(含嵌套块中的)名称函数
;;;***********************************************************
(defun ayGetAllEntInBLK (BlkEntName / xBlkName xBlkDef entName1 entType entNameList)
 (setq xBlkName (cdr (assoc 2 (entget BlkEntName))))
 (setq xBlkDef (tblobjname "Block" xBlkName))
 (while (setq entName1 (entnext xBlkDef))
(setq entType (cdr (assoc 0 (entget entName1))))
(if (= entType "INSERT")
 (setq entNameList
 (append (ayGetAllEntInBLK entName1) entNameList)
 )
 (setq entNameList (cons entName1 entNameList))
) ;end_if
(setq xBlkDef entName1)
 ) ;end_while entNameList
 entNameList
) ;end_defun
(princ)

smartstar · 发表于 2012-6-21 10:40:26

恳请高人出手相助，谢谢。

smartstar · 发表于 2012-6-21 20:14:44

顶出答案。

ZZXXQQ · 发表于 2012-6-21 21:07:00

这样就行。

游客，本帖隐藏的内容需要发帖数高于 5 才可浏览，你当前发帖数只有 0

smartstar · 发表于 2012-6-25 12:28:28

ZZXXQQ 发表于 2012-6-21 21:07
这样就行。
[/post]

谢谢版主回复。
试用了一下，没有成功。而且您给的程序里也没有对嵌套块的处理。

Gu_xl · 发表于 2012-6-25 13:18:54

smartstar 发表于 2012-6-25 12:28
谢谢版主回复。
试用了一下，没有成功。而且您给的程序里也没有对嵌套块的处理。

(defun delblkwipe (blkname / blkdef objname)
(setq blkdef
(vla-item (vla-get-blocks
(vla-get-ActiveDocument (vlax-get-acad-object)))
blkname))
(if (/= :vlax-true (vla-get-IsXRef blkdef))
(vlax-for obj blkdef
(cond
((= "AcDbWipeout" (setq objname (vla-get-ObjectName obj)))
(vla-delete obj)
)
((or (= "AcDbMInsertBlock" objname)
(= "AcDbBlockReference" objname)
)
(delblkwipe (vla-get-name obj))
)
)
)
)
)
;;
(defun c:111(/ e)
(while (and (setq e (car(entsel)))
(= "INSERT" (cdr (assoc 0 (entget e))))
)
(delblkwipe (cdr (assoc 2 (entget e))))
(command "_.regen")
)
(princ)
)

smartstar · 发表于 2012-6-27 18:12:08

劳烦G版主再修改一下。达到功能：将WIPEOUT实体转化为pline线，若不能转成pline线，炸成line线也行。G版主辛苦了，谢谢。

smartstar · 发表于 2012-6-28 18:21:49

劳烦G版主再次出手相助，谢谢。

Gu_xl · 发表于 2012-6-28 22:19:43

smartstar 发表于 2012-6-28 18:21
劳烦G版主再次出手相助，谢谢。

;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
;; http://www.theswamp.org/index.php?topic=28059.msg336431#msg336431
;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
(setq elst (entget wo)
u (cdr (assoc 11 elst))
v (cdr (assoc 12 elst))
mat (list u (mapcar '- v) '(0. 0. 1.))
)
(mapcar
'(lambda (p)
(mapcar '+
(mxv (trp mat) p)
(mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
(cdr (assoc 10 elst))
)
)
(cdr
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
)
)
)
)
;; Transpose a matrix Doug Wilson
(defun trp (m)
(apply 'mapcar (cons 'list m))
)
(mapcar 'list '(1 2 3) '(4 5 6) '(7 8 9 10))
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
(mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
(defun delblkwipe (blkname / blkdef objname)
(setq blkdef
(vla-item (vla-get-blocks
(vla-get-ActiveDocument (vlax-get-acad-object)))
blkname))
(if (/= :vlax-true (vla-get-IsXRef blkdef))
(vlax-for obj blkdef
(cond
((= "AcDbWipeout" (setq objname (vla-get-ObjectName obj)))
(setq pl (wipeout2plst (vlax-vla-object->ename obj))
pl (apply 'append (mapcar '(lambda (X) (list (car x) (cadr x)) ) pl))
)
(setq o
(vla-AddLightWeightPolyline blkdef (vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length pl)))
)
pl
)
)
)
(vla-put-closed o :vlax-true)
(vla-put-layer o (vla-get-layer obj))
(vla-delete obj)
)
((or (= "AcDbMInsertBlock" objname)
(= "AcDbBlockReference" objname)
)
(delblkwipe (vla-get-name obj))
)
)
)
)
)
;;
(defun c:111(/ e)
(while (and (setq e (car(entsel)))
(= "INSERT" (cdr (assoc 0 (entget e))))
)
(delblkwipe (cdr (assoc 2 (entget e))))
(command "_.regen")
)
(princ)
)

;; WO2PL (gile) 
;; Re-creates a wipeout boundary (lwpolyline) 
;; <a href="http://www.theswamp.org/index.php?topic=28059.msg336431#msg336431" target="_blank">http://www.theswamp.org/index.php?topic=28059.msg336431#msg336431</a> 
;; returns the wipeout point list (WCS) 
(defun wipeout2plst (wo / elst u v mat) 
  (setq         elst (entget wo) 
         u    (cdr (assoc 11 elst)) 
         v    (cdr (assoc 12 elst)) 
         mat  (list u (mapcar '- v) '(0. 0. 1.)) 
  ) 
  (mapcar 
    '(lambda (p) 
       (mapcar '+ 
                (mxv (trp mat) p) 
                (mapcar '(lambda (x y) (/ (+ x y) 2.)) u v) 
                (cdr (assoc 10 elst)) 
       ) 
     ) 
    (cdr 
      (mapcar 'cdr 
               (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst) 
      ) 
    ) 
  ) 
) 
 
;; Transpose a matrix Doug Wilson 
(defun trp (m) 
  (apply 'mapcar (cons 'list m)) 
) 
(mapcar 'list '(1 2 3) '(4 5 6)  '(7 8 9 10)) 
 
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky 
(defun mxv (m v) 
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m) 
) 
(defun delblkwipe  (blkname / blkdef objname) 
 
  (setq        blkdef 
 
         (vla-item (vla-get-blocks 
 
                     (vla-get-ActiveDocument (vlax-get-acad-object))) 
 
                   blkname)) 
 
  (if (/= :vlax-true (vla-get-IsXRef blkdef)) 
 
    (vlax-for obj  blkdef 
 
      (cond 
 
        ((= "AcDbWipeout" (setq objname (vla-get-ObjectName obj))) 
         (setq pl (wipeout2plst (vlax-vla-object->ename obj)) 
               pl (apply 'append (mapcar '(lambda (X) (list (car x) (cadr x)) ) pl)) 
               ) 
         (setq o 
                (vla-AddLightWeightPolyline blkdef (vlax-safearray-fill 
                                              (vlax-make-safearray 
                                                vlax-vbDouble 
                                                (cons 0 (1- (length pl))) 
                                              ) 
                                              pl 
                                            ) 
           ) 
               ) 
         (vla-put-closed o :vlax-true) 
         (vla-put-layer o (vla-get-layer obj)) 
         (vla-delete obj) 
 
         ) 
 
        ((or (= "AcDbMInsertBlock" objname) 
 
             (= "AcDbBlockReference" objname) 
 
             ) 
 
         (delblkwipe (vla-get-name obj)) 
 
         ) 
 
        ) 
 
      ) 
 
    ) 
 
  ) 
 
;; 
 
(defun c:111(/ e) 
 
  (while (and (setq e (car(entsel))) 
 
              (=  "INSERT" (cdr (assoc 0 (entget e)))) 
 
              ) 
 
    (delblkwipe (cdr (assoc 2 (entget e)))) 
 
    (command "_.regen") 
 
    ) 
 
  (princ) 
 
  )

smartstar · 发表于 2012-6-29 12:54:44

感谢G版主再次出手相助！！！

账号		自动登录	找回密码
密码			注册

感谢G版再次出手相助！为什么不能删除块中WIPEOUT实体呢？

点评

点评