谁能仿写一个“给图中的BLOCK添加遮罩”

朽木大师 · 发表于 2013-5-2 15:51:00

本帖最后由朽木大师于 2013-5-13 10:40 编辑

http://www.xdcad.net/forum/thread-667983-1-1.html
这里有这个帖，不过加载xdrx_api，还只能用于2004-2006 有没有高手也仿着写一个

Gu_xl · 发表于 2013-5-2 15:51:01

朽木大师发表于 2013-5-15 13:30
来明经只是偶尔找一个小工具，说实在，对程序基本上是一无所知

(defun c:tt (/ E EL NAME BLKDEF DOC OBJS LL UR MINS MAXS WIPE NEWOBJS)
(while
(and (setq e (car (entsel "\nSelect Insert:")))
(= "INSERT" (cdr (assoc 0 (setq el (entget e)))))
)
(setq name (cdr (assoc 2 el)))
(setq blkdef (vla-item
(vla-get-blocks
(setq
doc (vla-get-ActiveDocument (vlax-get-acad-object))
)
)
name
)
)
(vlax-for obj blkdef
(setq objs (cons obj objs))
(if
(not
(VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY 'vla-GetBoundingBox (list obj 'll 'ur))
)
)
(progn
(setq ll (vlax-safearray->list ll)
ur (vlax-safearray->list ur)
mins (cons ll mins)
maxs (cons ur maxs)
)
)
)
)
(setq ll (apply 'mapcar (cons 'min mins))
ur (apply 'mapcar (cons 'max maxs))
)
(command "_rectang" "_non" ll "_non" ur)
(command "_wipeout" "p" (entlast) "y")
(command "_wipeout" "f" "off")
(setq wipe (vlax-ename->vla-object (entlast)))
(setq Newobjs (vlax-invoke
doc
'CopyObjects
objs
(vla-get-ModelSpace doc)
)
)
(foreach a objs (vla-delete a))
(setq Newobjs (cons wipe Newobjs))
(vlax-invoke doc 'CopyObjects Newobjs blkdef)
(foreach a Newobjs (vla-delete a))
(vla-regen doc :vlax-true)
)
(princ)
)

(defun c:tt (/ E EL NAME BLKDEF DOC OBJS LL UR MINS MAXS WIPE NEWOBJS) 
  (while 
    (and (setq e (car (entsel "\nSelect Insert:"))) 
         (= "INSERT" (cdr (assoc 0 (setq el (entget e))))) 
    ) 
     (setq name (cdr (assoc 2 el))) 
     (setq blkdef (vla-item 
                    (vla-get-blocks 
                      (setq 
                        doc (vla-get-ActiveDocument (vlax-get-acad-object)) 
                      ) 
                    ) 
                    name 
                  ) 
     ) 
     (vlax-for obj blkdef 
       (setq objs (cons obj objs)) 
       (if 
         (not 
           (VL-CATCH-ALL-ERROR-P 
             (VL-CATCH-ALL-APPLY 'vla-GetBoundingBox (list obj 'll 'ur)) 
           ) 
         ) 
          (progn 
            (setq ll   (vlax-safearray->list ll) 
                  ur   (vlax-safearray->list ur) 
                  mins (cons ll mins) 
                  maxs (cons ur maxs) 
            ) 
 
          ) 
       ) 
     ) 
     (setq ll (apply 'mapcar (cons 'min mins)) 
           ur (apply 'mapcar (cons 'max maxs)) 
     ) 
     (command "_rectang" "_non" ll "_non" ur) 
     (command "_wipeout" "p" (entlast) "y") 
     (command "_wipeout" "f" "off") 
     (setq wipe (vlax-ename->vla-object (entlast))) 
     (setq Newobjs (vlax-invoke 
                     doc 
                     'CopyObjects 
                     objs 
                     (vla-get-ModelSpace doc) 
                   ) 
     ) 
     (foreach a objs (vla-delete a)) 
     (setq Newobjs (cons wipe Newobjs)) 
     (vlax-invoke doc 'CopyObjects Newobjs blkdef) 
     (foreach a Newobjs (vla-delete a)) 
     (vla-regen doc :vlax-true) 
  ) 
  (princ) 
)

朽木大师 · 发表于 2013-5-13 10:40:26

顶顶啊，虽然币不多

timmy521 · 发表于 2013-5-14 20:22:38

这样的程序我也想要。

x_s_s_1 · 发表于 2013-5-15 08:30:15

人家给了编程思路了，给你个画wipeout的代码，其它包围盒、提取块内图元且列表、删除块内图元，添加图元什么的代码论坛有。

;; CAB - Jan. 3,2010 to present
(defun MkWipeout(lst / c m p)
(setq lst (cons (last lst) lst)
p (apply 'mapcar (cons 'min lst))
m (apply 'max (mapcar '- (apply 'mapcar (cons 'max lst)) p))
c (mapcar '+ p (list (/ m 2.0) (/ m 2.0)))
)
(entmakex
(append (list '(000 . "WIPEOUT")
'(100 . "AcDbEntity")
'(100 . "AcDbWipeout")
(cons 10 (trans p 1 0))
(cons 11 (trans (list m 0.0) 1 0))
(cons 12 (trans (list 0.0 m) 1 0))
'(280 . 1)
'(071 . 2)
)
(mapcar
(function
(lambda (x)
(cons 14
(mapcar '(lambda (a b c) (/ (- a b) c))
x
c
(list m (- m))
)
)
)
)
lst
)
)
)
)
;;真彩色的含义
;;(+ (* BLUE 65536) (* GREEN 256) RED)
;;(+ (* 255 65536) (* 255 256) 255)=16777215

;;  CAB - Jan. 3,2010 to present 
(defun MkWipeout(lst / c m p) 
  (setq        lst (cons (last lst) lst) 
        p   (apply 'mapcar (cons 'min lst)) 
        m   (apply 'max (mapcar '- (apply 'mapcar (cons 'max lst)) p)) 
        c   (mapcar '+ p (list (/ m 2.0) (/ m 2.0))) 
  ) 
  (entmakex 
    (append (list '(000 . "WIPEOUT") 
                  '(100 . "AcDbEntity") 
                  '(100 . "AcDbWipeout") 
                  (cons 10 (trans p 1 0)) 
                  (cons 11 (trans (list m 0.0) 1 0)) 
                  (cons 12 (trans (list 0.0 m) 1 0)) 
                  '(280 . 1) 
                  '(071 . 2) 
            ) 
            (mapcar 
              (function 
                (lambda        (x) 
                  (cons        14 
                        (mapcar        '(lambda (a b c) (/ (- a b) c)) 
                                x 
                                c 
                                (list m (- m)) 
                        ) 
                  ) 
                ) 
              ) 
              lst 
            ) 
    ) 
  ) 
) 
;;真彩色的含义 
;;(+ (* BLUE 65536) (* GREEN 256) RED) 
;;(+ (* 255 65536) (* 255 256) 255)=16777215

朽木大师 · 发表于 2013-5-15 08:39:39

x_s_s_1 发表于 2013-5-15 08:30
人家给了编程思路了，给你个画wipeout的代码，其它包围盒、提取块内图元且列表、删除块内图元，添加图元什么 ...

不会，只会相当简单的LISP，希望有朋友能整理一份

朽木大师 · 发表于 2013-5-15 13:30:46

来明经只是偶尔找一个小工具，说实在，对程序基本上是一无所知

bai2000 · 发表于 2013-5-19 21:04:54

能改为框选块就更好

朽木大师 · 发表于 2013-5-20 08:10:09

Gu_xl 发表于 2013-5-19 16:02

要是再增加自动转方向就好

朽木大师 · 发表于 2013-5-20 08:11:54

Gu_xl 发表于 2013-5-19 16:02

希望G版大哥再抽时间能补充补充

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

谁能仿写一个“给图中的BLOCK添加遮罩”

最佳答案

相关帖子

点评

点评