可自由定制的最强劲的刷子

eachy · 发表于 2004-12-23 17:50:28

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

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

×

;;我也会编程, 可自由定制的最强劲的刷子
;;==============================================================
;;
;; Writen By Eachy 2004.12.23
;;
;; homepage: [url=http://www.xdcad.net]www.xdcad.net[/url]
;;
;;==============================================================
;;改特性的一种通用编程方法，变量名称使用特性名，用 eval 求值
;;==============================================================
(defun ea:put-property (obj plst /)
(mapcar '(lambda (p)
(if (eval p)
(vl-catch-all-apply
'vlax-put-property
(list obj p (eval p))
)
)
)
plst
)
)
;;==============================================================
;;示例
;;用上面的函数可以做出比CAD更最强劲的并可以自由定制的刷子
;; pl 中需要的特性参考联机帮助中各实体 Properties
;;==============================================================
(vl-load-com)
(defun c:ea:mat (/ e ss obj pl olderr myerr eDoc)
(defun myerr (msg)
(if (/= msg "取消")
(princ "\n*取消*")
)
(if pl
(progn
(mapcar '(lambda (x) (set x nil)) pl)
(setq pl nil)
)
)
(vla-endundomark eDoc)
(setq *error* olderr)
(princ)
)
(setq eDoc (vlax-get-property (vlax-get-acad-object) 'activedocument))
(vla-startundomark eDoc)
(setq olderr *error*
*error* myerr
)
(if (and (setq e (car (entsel "\n选择源对象: ")))
(progn
(princ "\n选择目标对象....")
(setq ss (ssget))
)
)
(progn
(setq obj (vlax-ename->vla-object e))
(mapcar '(lambda (p / var)
(if (not (vl-catch-all-error-p
(setq var (vl-catch-all-apply
'vlax-get-property
(list obj p)
)
)
)
)
(set p var)
(set p nil)
)
)
(setq pl '(truecolor color layer
linetype textstring
height stylename
textstyle rotation
thickness constandwidth
patternname patternscale
lineweight elevation
radius xscalefactor
yscalefactor zscalefactor
) ;_ 此处可根据需要增减
)
)
(setq ssl (sslength ss))
(while (> ssl 0)
(setq
obj (vlax-ename->vla-object (ssname ss (setq ssl (1- ssl))))
)
(ea:put-property obj pl)
)
(mapcar '(lambda (x) (set x nil)) pl)
(setq pl nil)
)
)
(setq *error* olderr)
(vla-endundomark eDoc)
(princ)
)
(princ "\nWriten By Eachy , From [url=http://www.xdcad.net]www.xdcad.net[/url]!")
(princ)

;;我也会编程, 可自由定制的最强劲的刷子                     
;;============================================================== 
;;                                                               
;;             Writen By Eachy    2004.12.23       
;;                                                               
;;              homepage: [url=http://www.xdcad.net]www.xdcad.net[/url]                         
;;                                                               
;;============================================================== 
;;改特性的一种通用编程方法，变量名称使用特性名，用 eval 求值    
;;============================================================== 
(defun ea:put-property (obj plst /) 
  (mapcar '(lambda (p) 
             (if (eval p) 
               (vl-catch-all-apply 
                 'vlax-put-property 
                 (list obj p (eval p)) 
               ) 
             ) 
           ) 
          plst 
  ) 
) 
;;============================================================== 
;;示例                                                          
;;用上面的函数可以做出比CAD更最强劲的并可以自由定制的刷子       
;; pl 中需要的特性参考联机帮助中各实体 Properties                
;;============================================================== 
(vl-load-com) 
(defun c:ea:mat        (/ e ss obj pl olderr myerr eDoc) 
  (defun myerr (msg) 
    (if        (/= msg "取消") 
      (princ "\n*取消*") 
    ) 
    (if        pl 
      (progn 
        (mapcar '(lambda (x) (set x nil)) pl) 
        (setq pl nil) 
      ) 
    ) 
    (vla-endundomark eDoc) 
    (setq *error* olderr) 
    (princ) 
  ) 
  (setq eDoc (vlax-get-property (vlax-get-acad-object) 'activedocument)) 
  (vla-startundomark eDoc) 
  (setq        olderr        *error* 
        *error*        myerr 
  ) 
  (if (and (setq e (car (entsel "\n选择源对象: "))) 
           (progn 
             (princ "\n选择目标对象....") 
             (setq ss (ssget)) 
           ) 
      ) 
    (progn 
      (setq obj (vlax-ename->vla-object e)) 
      (mapcar '(lambda (p / var) 
                 (if (not (vl-catch-all-error-p 
                            (setq var (vl-catch-all-apply 
                                        'vlax-get-property 
                                        (list obj p) 
                                      ) 
                            ) 
                          ) 
                     ) 
                   (set p var) 
                   (set p nil) 
                 ) 
               ) 
             (setq pl '(truecolor color          layer 
                                   linetype          textstring 
                                   height          stylename 
                                   textstyle          rotation 
                                   thickness          constandwidth 
                                   patternname          patternscale 
                                   lineweight          elevation 
                                   radius          xscalefactor 
                                   yscalefactor          zscalefactor 
                                  ) ;_ 此处可根据需要增减 
              ) 
      ) 
      (setq ssl (sslength ss)) 
      (while (> ssl 0) 
        (setq 
          obj (vlax-ename->vla-object (ssname ss (setq ssl (1- ssl)))) 
        ) 
        (ea:put-property obj pl) 
      ) 
      (mapcar '(lambda (x) (set x nil)) pl) 
      (setq pl nil) 
    ) 
  ) 
  (setq *error* olderr) 
  (vla-endundomark eDoc) 
  (princ) 
) 
(princ "\nWriten By Eachy , From [url=http://www.xdcad.net]www.xdcad.net[/url]!") 
(princ)

coolyxw · 发表于 2004-12-23 20:15:56

怎么用不了,输入mat提示为未知命令,贴出的代码还需要修改吗?

SLMin · 发表于 2004-12-23 22:50:44

最初由 coolyxw 发布
[B]怎么用不了,输入mat提示为未知命令,贴出的代码还需要修改吗? [/B]

应当输入 ea:mat~~~~~~

xyp1964 · 发表于 2004-12-23 23:30:31

输入 ea:mat 也不知怎么操作。

梦断江南 · 发表于 2004-12-23 23:38:41

借ea的东风，凑个热闹，这个程序的编译版本在cad外挂版块发过

;| (x-mprop e ss attlst) = 实体属性刷子函数-----梦断江南.2004.10
参数: e = 参照实体. ss = 要刷的实体选集 attlst = 适用的属性列表.(表)
返回: 空.中途显示参照实体有效属性列表((属性属性值)(...)...)
技巧: 使用了 vl-catch-all-*,避免出错退出.
实例: (x-mprop (car(nentsel)) (ssget) '(rotation color Height))
|;
(defun x-mprop (e ss attlst / attv attlst2)
(mapcar '(lambda(x)
(if(not(vl-catch-all-error-p(setq attv(vl-catch-all-apply 'vlax-get (list (x2o e) x)))))
(setq attlst2 (cons (list x attv) attlst2))
))
attlst
)
(princ "\n参照实体有效属性:")(mapcar 'princ attlst2)
(mapcar '(lambda(x)
(mapcar '(lambda(y)(not(vl-catch-all-error-p(vl-catch-all-apply 'vlax-put (list (x2o x) (car y)(cadr y))))))
attlst2
)
)
(xss2lst ss)
)(princ)
)
;;*****配套程序********
;; ss to ename lst
(defun xss2lst (ss / i e lst)
(setq i -1)
(while (setq e(ssname ss (setq i (1+ i))))
(setq lst (cons e lst))
)(reverse lst)
)
;; ename to vla-object
(defun x2o (e)
(vlax-ename->vla-object e)
)

;| (x-mprop e ss attlst) = 实体属性刷子函数-----梦断江南.2004.10 
参数: e = 参照实体. ss = 要刷的实体选集  attlst = 适用的属性列表.(表) 
返回: 空.中途显示参照实体有效属性列表((属性 属性值)(...)...) 
技巧: 使用了 vl-catch-all-*,避免出错退出. 
实例: (x-mprop (car(nentsel)) (ssget) '(rotation color Height)) 
|; 
(defun x-mprop (e ss attlst / attv attlst2) 
  (mapcar '(lambda(x) 
             (if(not(vl-catch-all-error-p(setq attv(vl-catch-all-apply 'vlax-get (list (x2o e) x))))) 
               (setq attlst2 (cons (list x attv) attlst2)) 
             )) 
          attlst 
  ) 
  (princ "\n参照实体有效属性:")(mapcar 'princ attlst2) 
  (mapcar '(lambda(x) 
             (mapcar '(lambda(y)(not(vl-catch-all-error-p(vl-catch-all-apply 'vlax-put (list (x2o x) (car y)(cadr y)))))) 
                     attlst2 
             ) 
           ) 
          (xss2lst ss) 
  )(princ) 
) 
 
;;*****配套程序******** 
;; ss to ename lst 
(defun xss2lst (ss / i e lst) 
  (setq i -1) 
  (while (setq e(ssname ss (setq i (1+ i)))) 
    (setq lst (cons e lst)) 
  )(reverse lst) 
) 
;; ename to vla-object 
(defun x2o (e) 
  (vlax-ename->vla-object e) 
)

[php]
;;----------------------函数应用:扩展命令--------------------------------;;
;;刷文字转角.
(defun c:mpttr () ;;不适用于文字对齐为 alinged 和 fit 情况.
  (x-mprop (car(nentsel "\n刷文字转角,不适用于文字对齐为 alinged 和 fit 情况,\n选参照实体:"))
   (progn (princ "\n选文本:")(ssget '((0 . "*TEXT"))))
   '(ROTATION))
)
;;刷文字高度.
(defun c:mptth () ;;不适用于文字对齐为 alinged 和 fit 情况.
  (x-mprop (car(nentsel "\n刷文字高度,不适用于文字对齐为 alinged 和 fit 情况,\n选参照实体:"))
   (progn (princ "\n选文本:")(ssget '((0 . "*TEXT"))))
   '(HEIGHT))
)
;;刷实体颜色.
(defun c:mpcol ()
  (x-mprop (car(nentsel "\n刷实体颜色,选参照实体:"))
   (progn (princ "\n选实体:")(ssget))
   '(COLOR))
)
;;刷实体图层.
(defun c:mplay ()
  (x-mprop (car(nentsel "\n刷实体图层,选参照实体:"))
   (progn (princ "\n选实体:")(ssget))
   '(LAYER))
)
;;刷文字内容.
(defun c:mpstr ()
  (x-mprop (car(entsel "\n刷文字内容,选参照实体:")) ;;对标注用entsel才可取得属性.
   (progn (princ "\n选*TEXT,ATT*,DIMENSION实体:")(ssget '((0 . "*TEXT,ATT*,DIMENSION"))))
   '(TEXTSTRING TextOverride))
)
;;-----------------------------------------------------------------------;;

[/php]

liuyj · 发表于 2004-12-24 09:23:44

ea兄的程序的确有点问题，不过应该是个很好的东西，期待完善。

LUCAS · 发表于 2004-12-24 12:27:48

最初由 eachy 发布
[B][CODE]
;;我也会编程, 可自由定制的最强劲的刷子
;;==============================================================
;;
... [/B]

誰說你不會编程了! 8-)
(PUT-PROPERTY OBJ PL) -> (EA:PUT-PROPERTY OBJ PL)

xyp1964 · 发表于 2004-12-24 12:48:58

我说eachy的第一个子程序怎么唱独脚戏呢。
难怪程序不能用。
还是楼上眼尖，佩服！

wkai · 发表于 2004-12-24 16:06:58

eachy 兄何处此言？令兄弟汗颜了。

梦断江南 · 发表于 2004-12-24 22:57:22

“我也会编程”是让大家说的：）

cy956 · 发表于 2004-12-25 09:46:51

从来不敢说会编程.

梦断江南 · 发表于 2004-12-25 10:08:45

好么，个个都很谦虚。
我cad都没学好呢

urljit · 发表于 2004-12-25 10:30:25

eachy如果这样说，我这样的人就应该说“刚刚听说过ｃａｄ”了

coolyxw · 发表于 2004-12-25 21:09:53

各位不要谦虚了,快整合下吧,我不知道怎么用,贴个可用的吧

aeo · 发表于 2004-12-25 22:01:04

象"自由选"一样，根据选到的物体，出不同的对话框，来个一网打尽.

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

[原创] 可自由定制的最强劲的刷子

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

评分

相关帖子

Re: [原创]：我也会编程, 可自由定制的最强劲的刷子