（原创）通用函数若干

cheng5276 · 发表于 2011-12-6 23:40:18

本帖最后由 cheng5276 于 2011-12-7 20:01 编辑

本人LISP学徒一个，发几个自用的通用函数与大家交流交流，写的可能比较啰嗦，也恳请大侠们指点指点，精简精简

一  双击反应器通用函数（2011年12月6日）

;;;双击反应器编辑文本
;不用卸载ARX的方法，否则第一次运行会出现命名空间的错误
;说明：首先在开头将双击编辑设为打开，分类别，需处理时则将双击编辑设为关闭，执行自定义代码
;切记在代码最后不可将双击编辑恢复为打开
(VL-LOAD-COM)
(if (not doubleclick_reactor1)(setq doubleclick_reactor1 (vlr-mouse-reactor "Object" '((:vlr-begindoubleclick . cheng5276_doubleclick)))))
(defun cheng5276_doubleclick (THEREACTOR THEPOINT / ent mode pt s1 ss style txt_0 txt_1 txt_x)
(double_head)
(cheng5276_SENDKEYS "DblClkEdit on ")
(SETQ PT (CAR THEPOINT))
(setq s1 (car (nentselp pt)));双击处的子体
(SETQ Style  (cdr (assoc 0 (entget s1))));
(cond
;模式一
((= style A
(cheng5276_SENDKEYS "DblClkEdit off ")
.......执行代码...........
)

;模式二
((= style B
(cheng5276_SENDKEYS "DblClkEdit off ")
.......执行代码...........
)

;模式三
((= style C
(cheng5276_SENDKEYS "DblClkEdit off ")
.......执行代码...........
)

);cond 结束
(double_end)
)

;通用sendkeys函数
(defun cheng5276_SendKeys (str /  Script)
  (vlax-invoke-method (setq  Script (vlax-create-object "WScript.Shell")) 'sendkeys str)
  (vlax-release-object Script)
  (princ)
)

;以下的错误处理函数请根据实际需要调整
(defun double_*error* (msg)
(setvar "cmdecho" 1)
(Setvar "pickstyle" PICK_BAK)
(setq *error* *error*_bak);恢复错误函数
(princ "\n用户取消\n")
  (princ)
)
;定义程序开头的备份参数函数
(defun double_head()
(setvar "cmdecho" 0)
(setq pick_bak (getvar "pickstyle"))
(setq *error*_bak *error*);备份error函数
  (setq *error* double_*error*);设定错误函数
)

;定义结束函数
(defun double_end()
(setvar "cmdecho" 1)
  (setvar "pickstyle" pick_bak)
  (setq *error* *error*_bak);恢复错误函数
  (princ)
)

二 DBX 通用处理函数（名称或文字内容遍历型，适用于块、参照、图片、文字对象等，可指定模型或图纸空间）
（2011年12月6日）

;+++++++辰 2011年12月6日
;+++++++dwg_path——"全路径"    space——模型还是图纸空间（0—模型空间 1—图纸空间  2—两者
;+++++++style——对象类型标识（0—块对象（包含参照）  1—图像对象 2—文字对象 3—  待续
;+++++++nametxtlst——当为块或图像时，则为其的名称表，（当需通配符支持时，应设好
;+++++++ 当为TEXT对象时，应为其文;字内容。非块或图像对象时可设为NIL
;+++++++ DATA ——主程序需传递给回调函数的数据表
;+++++++callbacks——真正要执行的回调函数（较简单时可直接写执行语句也行），至少需一个OBJ参数
(defun cheng5276-dbx-obj-cmd (dwg_path space style nametxtlst DATA callbacks  / blocks dbx file obj pspace save stylename x erro)
(setq file (open  "c:\\NT-LOGFILE.TXT" "a"));;与主程序中对应，用来记录无设定对象的图纸的列表，完毕后检查用
(setq save nil)
(setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." (substr (getvar "acadver") 1 2)) ))
  (vla-open dbx dwg_path)
  (setq blocks (Vlax-Get dbx 'Blocks))
(setq space (cond
((= space 0)
"*MODEL_SPACE"
)
((= space 1)
"*PAPER_SPACE*"
)
((= space 2)
"*MODEL_SPACE,*PAPER_SPACE*"
)
)
)
(setq stylename (cond
((= style 0)
"AcDbBlockReference"
)
((= style 1)
"AcDbRasterImage"
)
((= style 2)
"AcDbMText,AcDbText"
)
;++++++其他类型自行添加++++++
)
)
(setq stylename (strcase stylename));为保险转为大写吧
(vlax-for PSpace blocks
(setq erro (vl-catch-all-error-p (vl-catch-all-apply '(lambda() (setq nam (Vlax-Get PSpace 'Name)))))) ;当有空对象时会无法执行，不知何故，故加这个错误截取
(if (not erro)
(if (wcmatch (strcase nam) space);转为大写，有时模型空间块名时大写时小写。不要和上面的IF 合并，当碰到截取错误时，会出错
  (vlax-for obj PSpace
  (if (wcmatch (strcase (vla-get-ObjectName obj)) stylename) ;开始IF01
(cond ;开始COND
((< style 2)
(if (vl-member-if '(lambda(x) (wcmatch  (Vlax-Get obj 'Name) x)) nametxtlst);此处名称不能转为大写，块、参照或图片对象
(progn
(setq save t)
(eval callbacks)
)
)
)
;((= style 2) ;文字类对象
;++++++++++判断及执行代码++++++++++
;)

;++++++其他类型自行添加++++++

);结束COND
  );开始IF01
  )
  )
  )
  )

  (if save
  (vla-saveas dbx dwg_path)
  (print dwg_path FILE);无需保存，且将无此文件的提示写入临时的提示文件中
  )
  (CLOSE FILE)
(vlax-release-object dbx)
  )

【KAIXIN】 · 发表于 2011-12-7 08:10:51

不错通用函数我也在学习中

qjcpj · 发表于 2011-12-7 08:18:41

谢谢分享成果。

cheng5276 · 发表于 2011-12-7 19:59:39

本帖最后由 cheng5276 于 2011-12-7 20:02 编辑

三通用删除CAD图元对象（2011年12月7日刚写的一个）

语法： (DEL A)

功能与参数：

;辰 2011年12月7日
;删除各类选择的CAD图元对象
;参数A ——图元名、图元名表、SSGET选择集、单个OBJ、以及VAL构造的选择集均可
;;VL的'Delete方法比COMMAND略快些
;支持各类;加入vl-catch-all-apply错误截取函数，以防止部分图元处于锁定层（冻结层等），无法删除而造成的程序终止

源代码

(DEFUN DEL (A / style ename len i count)
(SETQ STYLE (type A))
(COND
;1 单个图元名时
((= STYLE 'ENAME)
(vl-catch-all-apply '(lambda () (Vlax-Invoke-Method (VLAX-ENAME->vla-OBJECT A) 'Delete)))
)
;2 图元名表
((= STYLE 'LIST)
(foreach ename A (vl-catch-all-apply '(lambda () (Vlax-Invoke-Method (VLAX-ENAME->vla-OBJECT ename) 'Delete))))
)
;3 通过SSGET 或SSADD构造的选择集
((= STYLE 'PICKSET)
(setq len (sslength A) i 0)
(repeat len
(vl-catch-all-apply '(lambda ()(Vlax-Invoke-Method (VLAX-ENAME->vla-OBJECT (ssname A i)) 'Delete)))
(setq i (1+ i))
)
)
;4 vla方法构造的选择集
((and (= STYLE 'VLA-OBJECT) (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (SETQ COUNT (Vlax-Get A 'Count))))))) ;vla方法构造的选择集
(SETQ I 0)
(REPEAT COUNT
(setq obj (Vlax-Invoke-Method A 'Item I ))
(vl-catch-all-apply '(lambda () (Vlax-Invoke-Method obj 'Delete)))
(setq i (1+ i))
)
)
; 5 vla方法选择的单个图元
((= STYLE 'VLA-OBJECT)
(vl-catch-all-apply '(lambda () (Vlax-Invoke-Method A 'Delete)))
)
; 6 其他不可删除的提示
(t
(alert "对象无法删除")
(quit)
)
)
)

cheng5276 · 发表于 2011-12-7 20:06:07

本帖最后由 cheng5276 于 2011-12-7 20:09 编辑

四通用原位复制CAD图元对象

语法： (COPY A)

功能与参数：

;辰 2011年12月7日
;功能：原位复制CAD对象,可复制锁定图层的内容
;参数A ——图元名、图元名表、SSGET选择集、单个OBJ、以及VAL构造的选择集均可
;返回值：复制后生成的图元名表

(DEFUN COPY (A / count ename i len obj ss sslst style)
(SETQ STYLE (type A) SS (SSADD))
(COND
;1 单个图元名时
((= STYLE 'ENAME)
(if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (Vlax-Invoke-Method (VLAX-ENAME->vla-OBJECT A) 'Copy)))))
(setq sslst (list (entlast)))
)
)
;2 图元名表
((= STYLE 'LIST)
(foreach ename A
(if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (Vlax-Invoke-Method (VLAX-ENAME->vla-OBJECT ename) 'Copy)))))
(ssadd (entlast) ss)
)
)
(setq sslst (cheng5276_ss->lst ss))
)
;3 通过SSGET 或SSADD构造的选择集
((= STYLE 'PICKSET)
(setq len (sslength A) i 0)
(repeat len
(if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda ()(Vlax-Invoke-Method (VLAX-ENAME->vla-OBJECT (ssname A i)) 'Copy)))))
(ssadd (entlast) ss)
)
(setq i (1+ i))
)
(setq sslst (cheng5276_ss->lst ss))
)
;4 vla方法构造的选择集
((and (= STYLE 'VLA-OBJECT) (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (SETQ COUNT (Vlax-Get A 'Count)))))))
(SETQ I 0)
(REPEAT COUNT
(setq obj (Vlax-Invoke-Method A 'Item I ))
(if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (Vlax-Invoke-Method obj 'Copy)))))
(ssadd (entlast) ss)
)
(setq i (1+ i))
)
(setq sslst (cheng5276_ss->lst ss))
)
; 5 vla单个图元
((= STYLE 'VLA-OBJECT)
(if (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (Vlax-Invoke-Method A 'Copy)))))
(setq sslst (list (entlast)))
)
)
)
sslst ;返回复制后的图元名表
)

【KAIXIN】 · 发表于 2011-12-7 20:15:53

本帖最后由【KAIXIN】于 2011-12-7 20:16 编辑

定义判断用的好

希望楼主能再接再厉！

cheng5276 · 发表于 2011-12-7 20:19:08

本帖最后由 cheng5276 于 2011-12-8 00:10 编辑

五 CAD图元对象分解通用函数

（DEL 与 COPY 采用的是常规的思路,这个换个写法，新手可能需要稍耗点脑子看代码了）

语法： (EXPLODE A)

功能与参数：

;辰 2011年12月7日
;功能：CAD图元对象分解，主要为获取分解后生成的图元待用
;参数A ——图元名、图元名表、SSGET选择集、单个OBJ、以及VAL构造的选择集均可
;返回值：分解后生成的图元名表，源对象不能被分解的（如圆弧、直线、椭圆等）也会被一并返回。

源代码：

(DEFUN Explode (A / count i obj objcmd s ss style s0 EX_A EX_B)
(setq STYLE (type A) s (entlast) ss (ssadd))

(defun EX_A (OBJCMD) ;定义对单个图元的分解函数（图元名或单个OBJ对象）
(SETQ OBJ (EVAL OBJCMD))
(IF (NOT (vl-catch-all-error-p (vl-catch-all-apply '(lambda() (Vlax-Invoke-Method obj 'Explode)))))
(Vlax-Invoke-Method obj 'Delete);vla的炸开方法会先对源对象进行复制然后炸开，故应删除源对象
(SSADD (vlax-vla-object->ename obj) SS)
)
)

(defun EX_B (count objcmd / i) ;定义选择集、图元名表的分解函数
(setq i 0)
(repeat count
(setq obj (eval objcmd))
(EX_A 'obj) ;调用单个图元分解函数
(setq i (1+ i))
)
)
;以下根据A的类型分类
(cond
;1 单个图元名对象
((= style 'ENAME)
(ex_A '(VLAX-ENAME->VLA-OBJECT A))
)

;2 图元名表，还可增加OBJ表类
((= STYLE 'LIST)
(setq COUNT (length A))
(EX_B count '(VLAX-ENAME->VLA-OBJECT (nth i A)))
)
;3 图元名表
((= STYLE 'PICKSET)
(setq COUNT (sslength A))
(EX_B count '(VLAX-ENAME->VLA-OBJECT (SSNAME A I)))
)
;4 VLA选择集
((and (= STYLE 'VLA-OBJECT) (not (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (SETQ COUNT (Vlax-Get A 'Count)))))))
(EX_B count '(Vlax-Invoke-Method A 'Item I ))
)
;5 单个OBJ对象
((= style 'VLA-OBJECT)
(ex_A 'A)
)
)
(while (setq s0 (entnext s))
(ssadd s0 ss)
(setq s s0)
)
(cheng5276_ss->lst ss)
)

LLXXZZ · 发表于 2011-12-8 12:40:02

支持你,你已经很厉害了....

cheng5276 · 发表于 2011-12-11 02:23:43

六 OPENDCL的树状列表转为lisp表（2011-12-11）

(写的比较啰嗦，语法也不是很精练，用了递归调用的方法，
只是论坛中好像没有相关的函数，所以也就放出来了，贻笑大方了。
高手如果愿意再帮忙精简精简就更好了)

;辰 2011-06-01
;name 为控件的名称
;parentitem为需由此展开的节点，
;path为parentitem的上一级路径、
;当parentitem  path均为空时则直接获取TREE的所有列表，
;设mode是本次执行结束后及时将C5276_DWGLST清空，便于给下次重新调用，（实际调用时请将MODE 设为T)
;(odcltree->lst "pldy_Form1_TreeControl2" nil t)

源代码
(defun odcltree->lst (name parentitem path mode / path1 firstchild name1 par_nextchild parentpath_label)
(setq name1 (read name))
(if (not parentitem)
(setq parentitem (dcl_Tree_GetRootItem (eval name1)))
)
(setq parentpath_label  (dcl_Tree_GetItemLabel (eval name1) parentitem))
(if (not path)
(setq path1 parentpath_label)
(setq path1 (strcat path "\\" parentpath_label))
)
(if mode
(setq c5276_lst nil)
)

(IF (setq firstchild  (dcl_Tree_GetFirstChildItem (eval name1) parentitem))
(progn
(odcltree->lst name firstchild path1 nil)
)
(setq c5276_lst (append c5276_lst (list path1)))
)
(if (setq par_nextchild (dcl_Tree_GetNextSiblingItem (eval name1) parentitem))
(progn
(if (or (= (vl-filename-directory path1) "") (= (vl-filename-directory path1) path1))
(setq path2  nil)
(setq path2 (vl-filename-directory path1))
)
(odcltree->lst name par_nextchild path2 nil)
)
)
c5276_lst
)

【KAIXIN】 · 发表于 2011-12-11 08:23:31

我也来凑凑热闹

;;; 返回层的顔色
(defun KX-get-laycolor (layname / la1 la col)
(setq la (cdr (assoc 2 (tblnext "layer" t))))
(while (/= la layname)
(setq la1 (tblnext "layer" nil)
la (cdr (assoc 2 la1))
col (cdr (assoc 62 la1))
)
)
(princ "\n颜色为 : ")
col
)

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

（原创）通用函数若干

点评

评分

本帖被以下淘专辑推荐:

相关帖子