|
这是网上看到的,希望对你有用 (defun make-a-block (sst blkn inp / ssb entlist count blklst tag)
;;;说明：本函数用块名重新定义一个块，sst 为图元名表，blkn为已存在的块名.
(setq tag (getvar "ucsorg"))
(setq inp (list (- (car inp) (car tag))
(- (cadr inp) (cadr tag))
(- (caddr inp) (caddr tag))
)
)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq ssb sst)
;;; (setq blknmaet blkn)
(setq count 0)
(setq blklst (ssadd))
(repeat (length ssb)
(setq entlist (entget (setq ent (nth count ssb))))
(setq count (1+ count))
(entmake entlist)
(ssadd (entlast) blklst)
) (command "block" blkn "y" inp blklst "")
(setvar "osmode" osm)
)
(defun redefin-block (sst blkn inp / ssb entlist count blklst tag)
;;;说明：本函数用块名重新定义一个块，sst 为图元名表，blkn为已存在的块名.
;;; (setq tag (getvar "ucsorg"))
;;; (setq inp (list (- (car inp) (car tag))
;;; (- (cadr inp) (cadr tag))
;;; (- (caddr inp) (caddr tag))
;;; )
;;; )
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq ssb sst)
;;; (setq blknmaet blkn)
(setq blklst (entget (tblobjname "block" blkn)))
(entdel (cdr (assoc -1 blklst)))
(entmake blklst)
(setq count 0)
(repeat (length ssb)
(setq entlist (entget (setq ent (nth count ssb))))
(setq count (1+ count))
(entmake entlist)
)
(entmake '((0 . "ENDBLK")))
;;; (command "block" blkn "y" inp blklst "")
(setvar "osmode" osm)
)
(defun c:eb1 (/ ss entlst inpoi kilobj killst
kiltyp blklst firn firnlst firntyp okname
qut tag
)
(command "undo" "be")
(while (= nil qut)
(setvar "errno" 0)
(setq ss (entsel "\n请选择块中要删除的一个实体："))
(if (/= 52 (getvar "errno"))
(if ss
(progn
(setq entlst (entget (car ss)))
(if (= "INSERT" (cdr (assoc 0 entlst)))
(progn
(setq sublst (nentselp "" (cadr ss)))
(setq subname (car sublst))
(if (> (length sublst) 2)
(progn (setq blkn (car (car (reverse sublst))))
(setq entlst (entget blkn))
(setq firn
(cdr (assoc -2
(tblsearch "block" (cdr (assoc 2 entlst)))
)
)
)
(setq firnlst (list ()))
(while firn
(if (not (eq firn subname))
(setq firnlst (append firnlst (list firn)))
)
(setq firn (entnext firn))
)
(setq tag (getvar "ucsorg")) (make-a-block
(cdr firnlst)
(cdr (assoc 2 entlst))
'(0 0 0)
)
)
(progn ;属性块
(alert "\n所选择的可能是属性，删不了！") ) ) )
(alert "请选择块！")
) ) ;end progn ) ;end if ss
(setq qut t)
)
) ;end while
(command "undo" "e")
(princ)
)
(defun c:eb (/ ss entlst inpoi kilobj killst
kiltyp blklst firn firnlst firntyp okname
qut inlst subent inp scl ang
)
(command "undo" "be")
(while (= nil qut)
(setvar "errno" 0)
(setq ss (entsel "\n请选择块中要删除的一个实体："))
(if (/= 52 (getvar "errno"))
(if ss
(progn
(setq entlst (entget (car ss)))
(if (= "INSERT" (cdr (assoc 0 entlst)))
(progn
;;; (setq inp (cdr (assoc 10 entlst)))
;;; (setq scl (cdr (assoc 41 entlst)))
;;; (setq ang (cdr (assoc 50 entlst)))
(setq subent (nentselp (cadr ss)))
(setq inlst (car (reverse subent)))
(if (> (length inlst) 1)
(progn
;(alert"\nblockin block")
(setq subent inlst)
)
)
(setq subname (car subent))
(setq sublst (entget subname))
(setq firn
(cdr (assoc -2
(tblsearch "block" (cdr (assoc 2 entlst)))
)
)
)
(setq firnlst (list ()))
(while firn
(if (not (eq firn subname))
(setq firnlst (append firnlst (list firn)))
)
(setq firn (entnext firn))
)
(make-a-block
(cdr firnlst)
(cdr (assoc 2 entlst))
'(0 0 0)
)
;;; (if (entmake sublst)
;;; (progn
;;; (setq el (entlast))
;;; (command "move" el "" '(0 0 0) (cdr inp))
;;; (if (> scl 0)
;;; (command "scale" el "" (cdr inp) scl)
;;; (progn
;;; (command "mirror"
;;; el
;;; ""
;;; (cdr inp)
;;; (list (car (cdr inp))
;;; (+ 100 (cadr (cdr inp)))
;;; (caddr (cdr inp))
;;; )
;;; "y"
;;; )
;;; (command "scale" el "" (cdr inp) (abs scl))
;;; )
;;; )
;;; (command "rotate" el "" (cdr inp) (rad->dec ang))
;;;
;;; )
;;; )
)
(alert "请选择块！")
) ) ;end progn ) ;end if ss
(setq qut t)
)
)
;end while
(command "undo" "e")
(princ)
) ;end function
(defun c:ade (/ ss n ssb ssd blk blkn blklst inpoi tag tinpoi)
;;;在块中加入图元
;;; 先选择要加入块中的图元，再选择块即可
(princ "\n请选择要加入块中的图元:")
(setq ss (ssget))
(if ss
(progn
(setq n -1)
(repeat (sslength ss)
(redraw (ssname ss (setq n (1+ n))) 3)
)
(command "undo" "be")
(setq blk (entsel "\n请选择一个块:"))
(if blk
(progn
(setq blk (car blk))
(setq blklst (entget blk))
(setq typ (cdr (assoc 0 blklst)))
(if (= "INSERT" typ)
(progn
(setq inpoi (cdr (assoc 10 blklst))) (setq b41 (cdr (assoc 41 blklst))
b42 (cdr (assoc 42 blklst))
b43 (cdr (assoc 43 blklst))
b50 (cdr (assoc 50 blklst))
b210 (cdr (assoc 210 blklst))
)
(if (or
(not (equal b210 '(0 0 1)))
(/= (abs b41) 1)
(/= (abs b42) 1)
(/= (abs b43) 1)
)
(progn
(alert
"由于该块比例不是1，或挤出方向不是Z,不能选择该种块！\n请选择它的一个没有变换的实例！"
)
(exit)
)
)
(setq tag (getvar "ucsorg"))
(setq tinpoi (list (- (car inpoi) (car tag))
(- (cadr inpoi) (cadr tag))
(- (caddr inpoi) (caddr tag))
)
)
(if (< b41 0)
(command "mirror"
ss
blk
""
tinpoi
(list (car tinpoi) (+ (cadr tinpoi) 5000))
"y"
)
)
(if (< b42 0)
(command "mirror"
ss
blk
""
tinpoi
(list (+ (car tinpoi) 50000) (cadr tinpoi))
"y"
)
)
(if (/= 0 b50)
(command "rotate" ss blk "" tinpoi (- 0 (rad->dec b50)))
)
(setq blkn (cdr (assoc 2 blklst)))
(command "explode" blk)
(setq ssb (ssget "p"))
(setq n -1)
(repeat (sslength ss)
(setq
ssd (append ssd (list (ssname ss (setq n (1+ n)))))
)
)
(setq n -1)
(repeat (sslength ssb)
(setq
ssd (append ssd (list (ssname ssb (setq n (1+ n)))))
)
)
(make-a-block ssd blkn inpoi) (command "erase" ss ssb "")
(command "insert" blkn tinpoi 1 1 0)
(setq blklst (entget (entlast)))
(princ blklst)
(setq blklst (subst (cons 41 b41) (assoc 41 blklst) blklst)
blklst (subst (cons 42 b42) (assoc 42 blklst) blklst)
blklst (subst (cons 43 b43) (assoc 43 blklst) blklst)
blklst (subst (cons 50 b50) (assoc 50 blklst) blklst)
blklst (subst (cons 210 b210) (assoc 210 blklst) blklst)
blklst (subst (cons 10 inpoi) (assoc 10 blklst) blklst)
)
(entmod blklst)
)
(alert "\n请选择块！")
)
)
)
(command "undo" "e")
)
)
(princ)
)
(defun rad->dec (rang / ret)
(setq ret (/ (* 180 rang) pi))
ret
)
(defun c:cb (/ setofval offobj off ent ext errv osm)
(defun offobj
(ent / elst subent scl inp sublst el ang ellst inlst tag)
(setq tag (getvar "ucsorg"))
(setq elst (entget (car ent)))
(if (= "INSERT" (cdr (assoc 0 elst)))
(progn
(setq subent (nentselp (cadr ent)))
(setq inlst (car (reverse subent)))
(if (> (length inlst) 1)
(progn
(setq subent inlst)
)
)
(if subent
(progn
(setq scl (cdr (assoc 41 elst)))
(setq inp (assoc 10 elst))
(setq ang (cdr (assoc 50 elst)))
(setq sublst (entget (car subent)))
(if (entmake sublst)
(progn
(setq el (entlast))
(command "move" el "" '(0 0 0) (cdr inp))
(if (> scl 0)
(command "scale" el "" (cdr inp) scl)
(progn
(command "mirror"
el
""
(cdr inp)
(list (car (cdr inp))
(+ 100 (cadr (cdr inp)))
(caddr (cdr inp))
)
"y"
)
(command "scale" el "" (cdr inp) (abs scl))
)
)
(command "rotate" el "" (cdr inp) (rad->dec ang))
(setq ellst (entget el))
(setq inp (cdr (assoc 10 ellst))) (setq inp (list (- (car inp) (car tag))
(- (cadr inp) (cadr tag))
(- (caddr inp) (caddr tag))
)
)
(command "move" el "" inp)
(princ "\n请选择放置位置:")
(while (/= 0 (getvar "cmdactive"))
(command pause)
)
;(entdel el)
)
) ) )
)
(progn
(setq inp (cdr (assoc 10 elst)))
(setq inp (list (- (car inp) (car tag))
(- (cadr inp) (cadr tag))
(- (caddr inp) (caddr tag))
)
)
(command "copy" (car ent) "" inp)
(princ "\n请选择放置位置:")
(while (/= 0 (getvar "cmdactive"))
(command pause)
)
)
)
)
(command "undo" "be")
(while (= nil ext)
(setvar "errno" 0)
(setq ent (entsel "\n请选择要复制的对象:"))
(setq errv (getvar "errno"))
(cond
((= 52 errv) (setq ext t))
((= 0 errv) (offobj ent))
)
)
(command "undo" "e")
(princ)
)
(defun c:cb1 (/ setofval offobj off ent ext errv osm)
(defun offobj
(ent / elst subent sube scl inp
sublst el ang ellst inlst tag n
cpss
)
(setq tag (getvar "ucsorg"))
(setq elst (entget (car ent)))
(if (= "INSERT" (cdr (assoc 0 elst)))
(progn
(setq scl (cdr (assoc 41 elst)))
(setq inp (cdr (assoc 10 elst)))
(setq inp (list (- (car inp) (car tag))
(- (cadr inp) (cadr tag))
(- (caddr inp) (caddr tag))
)
)
(setq ang (cdr (assoc 50 elst)))
(setq cpss (ssadd))
(while (setq sube (nentsel "\n请选择要复制的图元:"))
(if (> (length sube) 2)
(progn
(setq mname (last sube))
(while (listp mname)
(setq mname (last mname))
)
(if (equal mname (car ent))
(progn
(setq inlst (car (reverse sube)))
(if (> (length inlst) 1)
(progn
(setq subent (car inlst))
)
(setq subent (car sube))
)
(setq sublst (entget subent))
(if (entmake sublst)
(progn
(setq el (entlast))
(command "move" el "" (list (- 0 (car tag))(- 0 (cadr tag))(- 0 (caddr tag))) inp)
(if (> scl 0)
(command "scale" el "" inp scl)
(progn
(command "mirror"
el
""
inp
(list (car inp)
(+ 100 (cadr inp))
(caddr inp)
)
"y"
)
(command "scale" el "" inp (abs scl))
)
)
(command "rotate"
el
""
inp
(rad->dec ang)
)
(ssadd el cpss)
(redraw el 3)
)
)
)
(alert"\n该图元不是所选块中的对象！")
)
)
(progn
(alert "\n选择的不是块！")
)
)
)
(if (> (sslength cpss) 0)
(progn
(setq ellst (entget el))
(command "move" cpss "" inp)
(princ "\n请选择放置位置:")
(while (/= 0 (getvar "cmdactive"))
(command pause)
)
)
)
)
(progn
(setq inp (cdr (assoc 10 elst)))
(setq inp (list (- (car inp) (car tag))
(- (cadr inp) (cadr tag))
(- (caddr inp) (caddr tag))
)
)
(command "copy" (car ent) "" inp)
(princ "\n请选择放置位置:")
(while (/= 0 (getvar "cmdactive"))
(command pause)
)
)
)
)
(command "undo" "be")
(while (= nil ext)
(setvar "errno" 0)
(setq ent (entsel "\n请选择要一个块:"))
(setq errv (getvar "errno"))
(cond
((= 52 errv) (setq ext t))
((= 0 errv) (offobj ent))
)
)
(command "undo" "e")
(princ)
)
(princ
"\n块操作程序，程序编写：英雄无敌。\n使用方法:在块中加入对象：ade;复制单个：cb;复制多个：cb1;删除：eb。"
)
(princ) | 
发表于 2007-11-7 10:45
置顶卡
变色卡
显身卡
楼主