SS:MAP & ModEnt

Free-Lancer · 发表于 2013-5-15 09:17:45

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有帐号？立即注册

x

;; Form www.xdcad.net 2005.9.21
;;对选择集执行某一函数操作
;; func 函数定义，参数为实体
;; ss 选择集
(defun SS:MAP (func ss / n)
(if (eq 'PICKSET (type ss))
(repeat (setq n (fix (sslength ss))) ;_ fixed
(apply func (list (ssname ss (setq n (1- n)))))
)
)
)
;;功能：修改实体用(entmod)
;;调用格式：(xdrx_ModEnt <组码1> <修改后的值> [组码2] [修改后的值] ... [组码n] [修改后的值])
;;说明：组码和修改的值必须配对出现，可以提供多个配对。
(defun modent (el lst)
(while lst
(if (assoc (car lst) el)
(setq el (subst (cons (car lst) (cadr lst))
(assoc (car lst) el)
el
)
)
(setq el (append el (list (cons (car lst) (cadr lst)))));_没有的组码要附加到最后
)
(setq lst (cddr lst))
)
(entmod el)
)
;;示例：将选取的文字字高修改为400,图层修改为mytxt , 字符改为 dde ,颜色改为 1
(defun c:tt ()
(if (setq ss (ssget '((0 . "text"))))
(ss:map '(lambda (x)
(modent (entget x) '(40 100 8 "mytxt" 1 "dde" 62 1))
)
ss
)
)
(princ)
)

;; Form <a href=\"http://www.xdcad.net\" target=\"_blank\">www.xdcad.net</a>  2005.9.21 
;;对选择集执行某一函数操作 
;; func 函数定义，参数为实体 
;; ss   选择集 
(defun SS:MAP (func ss / n) 
  (if (eq 'PICKSET (type ss)) 
    (repeat (setq n (fix (sslength ss))) ;_ fixed 
      (apply func (list (ssname ss (setq n (1- n))))) 
    ) 
  ) 
) 
;;功    能：修改实体用(entmod) 
;;调用格式：(xdrx_ModEnt <组码1> <修改后的值> [组码2] [修改后的值] ... [组码n] [修改后的值]) 
;;说    明：组码和修改的值必须配对出现，可以提供多个配对。 
(defun modent (el lst) 
  (while lst 
    (if (assoc (car lst) el) 
      (setq el (subst (cons (car lst) (cadr lst)) 
        (assoc (car lst) el) 
        el 
        ) 
      ) 
      (setq el (append el (list (cons (car lst) (cadr lst)))));_没有的组码要附加到最后 
    ) 
    (setq lst (cddr lst)) 
  ) 
  (entmod el) 
) 
;;示    例：将选取的文字字高修改为400,图层修改为mytxt , 字符改为 dde ,颜色改为 1 
(defun c:tt () 
  (if (setq ss (ssget '((0 . "text")))) 
    (ss:map '(lambda (x) 
        (modent (entget x) '(40 100 8 "mytxt" 1 "dde" 62 1)) 
      ) 
     ss 
    ) 
  ) 
  (princ) 
)

taner · 发表于 2013-5-26 15:32:40

;;;改LEEMAC的http://www.theswamp.org/index.php?topic=32743.0
(defun _offset (ss pt dis / l obj)
((lambda ()
(cond
((not (and
(eq 'PICKSET (type ss))
(numberp dis)
(vl-consp pt)
)
)
)
((SSMAP2 (LAMBDA (Ent)
(if (vlax-method-applicable-p (setq obj
(vlax-ename->vla-object ent)
)
'Offset
)
(mapcar
(function vla-delete)
(car (setq l (append
(vl-sort (mapcar
(function (lambda
(x)
(vlax-invoke obj 'Offset x)
)
)
(list dis (- dis))
) (function (lambda
(a b)
(>
(distance pt
(vlax-curve-getClosestPointto
(car a) pt
)
)
(distance pt
(vlax-curve-getClosestPointto
(car b) pt
)
)
)
)
)
)
(cdr l)
)
)
)
)
)
) SS
)
)
)
)
)
(apply
(function append)
(cdr l)
)
)

;;;改LEEMAC的http://www.theswamp.org/index.php?topic=32743.0 
(defun _offset (ss pt dis / l obj) 
  ((lambda () 
     (cond 
       ((not (and 
               (eq 'PICKSET (type ss)) 
               (numberp dis) 
               (vl-consp pt) 
             ) 
        ) 
       ) 
       ((SSMAP2 (LAMBDA (Ent) 
                    (if (vlax-method-applicable-p (setq obj 
                                                        (vlax-ename->vla-object ent) 
                                                  ) 
                                                  'Offset 
                        ) 
                      (mapcar 
                        (function vla-delete) 
                        (car (setq l (append 
                                       (vl-sort (mapcar 
                                                  (function (lambda 
                                                              (x) 
                                                              (vlax-invoke obj 'Offset x) 
                                                            ) 
                                                  ) 
                                                  (list dis (- dis)) 
                                                ) (function (lambda 
                                                              (a b) 
                                                              (> 
                                                                 (distance pt 
                                                                           (vlax-curve-getClosestPointto 
                                                                                                         (car a) pt 
                                                                           ) 
                                                                 ) 
                                                                 (distance pt 
                                                                           (vlax-curve-getClosestPointto 
                                                                                                         (car b) pt 
                                                                           ) 
                                                                 ) 
                                                              ) 
                                                            ) 
                                                  ) 
                                       ) 
                                       (cdr l) 
                                     ) 
                             ) 
                        ) 
                      ) 
                    ) 
                  ) SS 
        ) 
       ) 
     ) 
   ) 
  ) 
  (apply 
    (function append) 
    (cdr l) 
  ) 
)

/db_自贡黄明儒_ · 发表于 2013-5-15 09:47:31

对于好贴,我们通常要吹毛求疵

,(setq n (fix (sslength ss)))这里是不是可以不用fix?

XDSoft · 发表于 2013-5-15 10:02:40

函数很智能啊。

xshrimp · 发表于 2013-5-15 10:33:05

楼主试试能做到格式刷的效果吧?点一个,修改的效果马上能看见?

sicky111 · 发表于 2013-5-15 10:54:45

好贴，好程式。

wowan1314 · 发表于 2013-5-15 11:12:27

xshrimp 发表于 2013-5-15 10:33
楼主试试能做到格式刷的效果吧?点一个,修改的效果马上能看见?

改造为格式刷一样，点一个修改一个，框一次修改一次，立竿见影
(defun c:t11 ()
  (while (setq ss (ssget ":S" '((0 . "text"))))
(ss:map '(lambda (x)
      (modent (entget x) '(40 400 1 "dde" 62 1))
   )
   ss
)
  )
  (princ)
)

xshrimp · 发表于 2013-5-15 14:09:09

再来点要求,根据格式刷的使用习惯,没有选中是不退出程序,点击鼠标右键或ESC才退出.

wowan1314 · 发表于 2013-5-15 14:38:10

本帖最后由 wowan1314 于 2013-5-15 14:40 编辑

xshrimp 发表于 2013-5-15 14:09
再来点要求,根据格式刷的使用习惯,没有选中是不退出程序,点击鼠标右键或ESC才退出.

我再改！像格式刷一样，不停运行，即改即显，选不中也不退出，右键或ESC退出
(defun c:t11 ()
  (while (not (member (car (grread T 12 2)) '(11 12 25)))
(setq ss (ssget ":S" '((0 . "text"))))
(ss:map '(lambda (x)
      (modent (entget x) '(40 400 1 "dde" 62 1))
   )
   ss
)
  )
  (princ)
)

Lispboy · 发表于 2013-5-15 15:02:09

wowan1314 发表于 2013-5-15 14:38
我再改！像格式刷一样，不停运行，即改即显，选不中也不退出，右键或ESC退出
(defun c:t11 ()
(while ...

:lol 打死也不退，刷死你。

Lispboy · 发表于 2013-5-15 15:07:36

wowan1314 发表于 2013-5-15 14:38
我再改！像格式刷一样，不停运行，即改即显，选不中也不退出，右键或ESC退出
(defun c:t11 ()
(while ...

即改即显，选不中也不退出

我是对你这句话开句玩笑尼，程序很好。:D

taner · 发表于 2013-5-25 16:23:16

;;;收集了好久的
(DEFUN SSMAP1 (FUNC SS / N)
(if (eq 'PICKSET (type ss))
(REPEAT (SETQ N (SSLENGTH SS))
(VL-CATCH-ALL-APPLY FUNC (LIST (SSNAME SS (SETQ N (1- N)))))
)
)
)
(DEFUN SSMAP2 (FUNC SS / N)
(AND
(eq 'PICKSET (type ss))
(REPEAT (SETQ N (SSLENGTH SS))
(VL-CATCH-ALL-APPLY (QUOTE FUNC) (LIST (SSNAME SS (SETQ N (1- N)))))
)
)
)
(DEFUN SSMAP3 (FUNC SSET / N ENAME)
(AND
(eq 'PICKSET (type sset))
(SETQ N -1)
(WHILE (SETQ ENAME (SSNAME SSET (SETQ N (1+ N))))
(VL-CATCH-ALL-APPLY (FUNCTION (LAMBDA ()
(FUNC ENAME)
)
)
)
)
)
)
(DEFUN SSMAP4 (FUNC SSET / N ENAME)
(AND
(SETQ FUNC (EVAL FUNC))
(eq 'PICKSET (type sset))
(SETQ N -1)
(WHILE (SETQ ENAME (SSNAME SSET (SETQ N (1+ N))))
(VL-CATCH-ALL-APPLY (FUNCTION (LAMBDA ()
(FUNC ENAME)
)
)
)
)
)
)

;;;收集了好久的 
(DEFUN SSMAP1 (FUNC SS / N) 
  (if (eq 'PICKSET (type ss)) 
    (REPEAT (SETQ N (SSLENGTH SS)) 
      (VL-CATCH-ALL-APPLY FUNC (LIST (SSNAME SS (SETQ N (1- N))))) 
    ) 
  ) 
) 
(DEFUN SSMAP2 (FUNC SS / N) 
  (AND 
    (eq 'PICKSET (type ss)) 
    (REPEAT (SETQ N (SSLENGTH SS)) 
      (VL-CATCH-ALL-APPLY (QUOTE FUNC) (LIST (SSNAME SS (SETQ N (1- N))))) 
    ) 
  ) 
) 
(DEFUN SSMAP3 (FUNC SSET / N ENAME) 
  (AND 
    (eq 'PICKSET (type sset)) 
    (SETQ N -1) 
    (WHILE (SETQ ENAME (SSNAME SSET (SETQ N (1+ N)))) 
      (VL-CATCH-ALL-APPLY (FUNCTION (LAMBDA () 
              (FUNC ENAME) 
            ) 
        ) 
      ) 
    ) 
  ) 
) 
(DEFUN SSMAP4 (FUNC SSET / N ENAME) 
  (AND 
    (SETQ FUNC (EVAL FUNC)) 
    (eq 'PICKSET (type sset)) 
    (SETQ N -1) 
    (WHILE (SETQ ENAME (SSNAME SSET (SETQ N (1+ N)))) 
      (VL-CATCH-ALL-APPLY (FUNCTION (LAMBDA () 
              (FUNC ENAME) 
            ) 
        ) 
      ) 
    ) 
  ) 
)

GTJ116600 · 发表于 2013-5-25 16:33:05

好贴。woman1314改的也非常好。

taner · 发表于 2013-5-25 16:39:26

;;;不知道如何修改不了自己的贴子了
;;;运行以下代码
((LAMBDA ()
(SETQ SS (SSGET))
(BENCHMARK '((SSMAP1 '(LAMBDA (E)
(VLA-PUT-COLOR (VLAX-ENAME->VLA-OBJECT E) 5)
) SS
)
(SSMAP2 (LAMBDA (E)
(VLA-PUT-COLOR (VLAX-ENAME->VLA-OBJECT E) 5)
) SS
)
(SSMAP3 (LAMBDA (E)
(VLA-PUT-COLOR (VLAX-ENAME->VLA-OBJECT E) 5)
) SS
)
(SSMAP4 '(LAMBDA (E)
(VLA-PUT-COLOR (VLAX-ENAME->VLA-OBJECT E) 5)
) SS
)
)
)
)
)
;;;测试结果
Elapsed milliseconds / relative speed for 4096 iteration(s):
(SSMAP2 (LAMBDA (E) (vla-put-Color (...).....1435 / 2.00 <fastest>
(SSMAP3 (LAMBDA (E) (vla-put-Color (...).....1482 / 1.94
(SSMAP4 (QUOTE (LAMBDA (E) (vla-put-...).....1497 / 1.92
(SSMAP1 (QUOTE (LAMBDA (E) (vla-put-...).....2871 / 1.00 <slowest>

复制代码

XDSoft · 发表于 2013-5-25 16:43:22

taner 发表于 2013-5-25 16:39

编辑帖子

taner · 发表于 2013-5-26 13:34:03

;;;应该是出自EA
(DEFUN ENTMODE-ELIST (EL TYLST / C)
(FOREACH N TYLST
(IF (SETQ C (ASSOC (CAR N) EL))
(SETQ EL (SUBST
N
C
EL
)
)
(SETQ EL (APPEND
EL
(LIST N)
)
)
)
)
(ENTMOD EL)
)

帐号		自动登录	找回密码
密码			立即注册

[他山之石] SS:MAP & ModEnt

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

点评

评分

点评

评分

点评

评分

点评

评分