[求助]如何双击一个块，就执行一个指定的lisp程序？

clh521 发表于 2009-6-12 12:04:00

比如，我双击一个“图框”的块，就运行一个我自已编的用来打印的lisp程序：dy.lsp

masterlong 发表于 2009-6-15 03:33:00

根据以前论坛一个帖子改的 有自己的注释 改一下就可以满足你的要求 (defun c:sw()  (load "双击测试.lsp") (princ) )(defun jb:LoadDoublClickReactor (/)  (vl-load-com)  ;0语句功能注释：：：创建鼠标双击反应器  (if (/= (type jbDoubleClickReactor) 'VLR-Mouse-Reactor)   (setq jbDoubleClickReactor  (VLR-Mouse-Reactor nil '((:VLR-beginDoubleClick . jb:beginDoubleClick))))   vlr-editor-reactor  )  ;0语句功能注释：：：测试反应器是否已激活  (if (not (vlr-added-p jbDoubleClickReactor))   (vlr-add jbDoubleClickReactor)  )  ;0语句功能注释：：：卸载acdblclkedit.arx  (if (member "acdblclkedit.arx" (arx)) (arxunload "acdblclkedit.arx" nil)) (princ) )(defun jb:beginDoubleClick ( reactorObject Listofsomething / point obj owner ownerobj command-list cmd gripset) ;;(princ "\n双击响应\n")  (if (vl-catch-all-error-p (vl-catch-all-apply 'trans (list (car Listofsomething) 0 1)))   (princ "PaperSpace")   (progn    (setq cmd "_.PROPERTIES" ; command default     point Listofsomething     obj (car (nentselp (trans (car point) 0 1)))     owner (car (cadddr (nentselp (trans (car point) 0 1))))     gripset (cadr (ssgetfirst))     doc (vlax-get (vlax-get-acad-object) "activedocument")    )   (if obj     (progn      (cond       (owner (setq ownerobj (strcase (vlax-get (vlax-ename->vla-object owner) "objectname"))))       ( T (setq ownerobj (strcase (vlax-get (vlax-ename->vla-object obj) "objectname"))))      )      ;0《《这里是被我替换修改部分的位置》》      ;1我的修改,便于修改设置      (setq command-list (get-com-list))            (foreach x command-list       (if (= (car x) ownerobj)(setq cmd(cdr x)))      )   ;2这个位置我要进行替换，加入图块内容识别，重点在“3”   ;|      (cond       ( (= cmd "_.REFEDIT") (princ "1图块  ") (setq cmd "_.refedit (princ (cdr (nentselp (trans(car point)0 1)))) ") )       ( (= cmd "_.ATTEDIT") (princ "2属性块") (setq cmd "_.attedit (princ obj) ") )       ( (= cmd "_.EATTEDIT")(princ "3属性块") (setq cmd "_.eattedit (princ obj) ") )       ( T (setq cmd(strcat cmd " ")))      )   |;   ;0000我想直接用command函数,不能用      ;;(vla-sendcommand doc cmd)       ;3以下是我替换的内容 (cond ;0----0----0图块或属性块，均经过识别后再分配新的程序  ( (or (= cmd "_.REFEDIT")(= cmd "_.EATTEDIT")) (属性块识别) ) ;4以下内容可用，主要用途在于：当选择图块或属性块的非属性部分时，调用“参照编辑程序”。 ;4屏蔽的原因是，根据图块名称选择相应的程序。若开启这部分程序，需特殊处理的属性块必须选属性图元，不能选其它图元。 ;|  ( (= cmd "_.REFEDIT")             ;;;楼主需要改的就是这段代码   ;;(princ "1图块  ")   ;;(setq cmd "_.refedit (princ (cdr (nentselp (trans(car point)0 1)))) ")   (setq cmd "_.refedit ")   (vla-sendcommand doc cmd)  ) |; ;|  不调用这个命令  ( (= cmd "_.ATTEDIT")   (princ "2属性块")   (setq cmd "_.attedit (princ obj) ")   (vla-sendcommand doc cmd)  ) |;  ( (= cmd "_.EATTEDIT")(属性块识别))  ;3替换的就是这一句 ;4上一句不替换情况下的程序段 ;|  ( (= cmd "_.EATTEDIT")   ;;(setq cmd "_.eattedit (princ obj) ")   (setq cmd "_.eattedit ")   (vla-sendcommand doc cmd)  ) |;  ( T (setq cmd (strcat cmd " ")) (vla-sendcommand doc cmd) ) )     )    )   )  ) (princ) );0----0----0 ;1属性块识别将生成一个全局参数，用来给属性块相应程序调用 ;2该全局参数格式 ( 图元名 . 选取点 ) ;3图元名是主图元 (defun 属性块识别( / a loop b b0)      ;;(princ "\n--属性块识别--\n")  ;;(setq cmd "_.eattedit ")(vla-sendcommand doc cmd);;  (cond   ;9999 owner为T时，代表主图元   ( owner (setq ##双击图块## (cons owner point)) )   ;9999 owner为nil时，需要另外获取主图元   ( T    (setq b obj)    (setq loop T)    (while loop     (setq b (entnext b))     (setq c (entget b))     (setq c0 (cdr (assoc 0 c)))     (if (= c0 "SEQEND")      (setq cf2 (cdr (assoc -2 c)) loop Nil)     )    )    (setq ##双击图块## (cons cf2 point))   )  )  (princ "\n")(princ (setq blkname (cdr (assoc 2 (entget (car ##双击图块##))))))(princ "\n")  (cond   ( (wcmatch blkname "QGY_TK-*")    (princ "轻工院图框....启动图框编辑器....")(princ "\n")    (redraw (car ##双击图块##) 4)    (setq ##QGYTK_obj## ##双击图块##)  ;;临时设置    (vla-sendcommand doc "##vf ")   )   ;;( () () )   ;;( () () )   ( T    (setq ##双击图块## Nil)    (cond     ( (= cmd "_.REFEDIT" )(setq cmd "_.refedit ")  (vla-sendcommand doc cmd) )     ( (= cmd "_.EATTEDIT")(setq cmd "_.eattedit ") (vla-sendcommand doc cmd) )    )   )  )  ;;(princ "主图元=")(princ ##双击图块##) (princ) ) ;3我的修改 (defun get-com-list(/ infile infp inf)          ;;(princ "\n--get-com-list--\n")  (setq infile  (open "D:\\@@_new_lisp\\双击设置.no" "r") )  (setq infp '() )  (while (setq inf (read-line infile) )   (setq inf (read inf) )   (setq infp (cons inf infp) )  )  (close infile)  (reverse infp) ) ;4我的修改 ;| 双击设置.no  为文本文件 放于CAD主程序根目录 文件格式如下 ("ACDBBLOCKREFERENCE" . "_.REFEDIT")  图块 ("ACDBATTRIBUTE" . "_.ATTEDIT")   块属性 |;;0被我修改替换掉的部分 ;|     (setq command-list    (list     (cons "ACDBBLOCKREFERENCE" "_.REFEDIT")     (cons "ACDBATTRIBUTE" "_.ATTEDIT")   ;;调用这个命令比较好，EATTEDIT     (cons "ACDBMTEXT" "_.DDEDIT")     (cons "ACDBTEXT" "_.DDEDIT")     (cons "ACDBROTATEDDIMENSION" "_.DDEDIT")     (cons "ACDBALIGNEDDIMENSION" "_.DDEDIT")     (cons "ACDBORDINATEDIMENSION" "_.DDEDIT")     (cons "ACDBDIAMETRICDIMENSION" "_.DDEDIT")     (cons "ACDBRADIALDIMENSION" "_.DDEDIT")     (cons "ACDB2LINEANGULARDIMENSION" "_.DDEDIT")     (cons "ACDBMLINE" "_.MLEDIT")     (cons "ACDBATTRIBUTEDEFINITION" "_.DDEDIT")     (cons "ACDBHATCH" "_.HATCHEDIT")     (cons "ACDBRASTERIMAGE" "_.IMAGEADJUST")     (cons "AECDBWALL" "_.PROPERTIES")     (cons "AECDBDOOR" "_.PROPERTYDATAEDIT")     (cons "AECDBWINDOW" "_.PROPERTIES")     (cons "AECDBWINDOWASSEMBLY" "_.PROPERTIES")     (cons "AECDBCURTAINWALLLAYOUT" "_.PROPERTIES")     (cons "AECDBSPACE" "_.PROPERTYDATAEDIT")     (cons "AECDBSTAIR" "_.PROPERTIES")     (cons "AECDBRAILING" "_.PROPERTIES")     (cons "AECDBMVBLOCKREF" "_.PROPERTIES")     (cons "AECDBOPENING" "_.PROPERTIES")     (cons "AECDBCEILINGGRID" "_.PROPERTIES")     (cons "AECDBCOLUMNGRID" "_.PROPERTIES")     (cons "AECDBSLAB" "_.PROPERTIES")     (cons "AECSDBMEMBER" "_.PROPERTIES")     (cons "AECDBMASSELEM" "_.PROPERTIES")     (cons "AECDBROOF" "_.PROPERTIES")     (cons "AECDBROOFSLAB" "_.PROPERTIES")     (cons "AECDBCAMERA" "_.PROPERTIES")     (cons "AECDBSCHEDULETABLE" "_.PROPERTIES")    )   ) |;;;(progn (jb:LoadDoublClickReactor) (princ)) ;;;;;-------------------------------------------------------- ;;;双击设置.no ("ACDBBLOCKREFERENCE" . "_.REFEDIT") ("ACDBATTRIBUTE" . "_.EATTEDIT") ("ACDBMTEXT" . "_.DDEDIT") ("ACDBTEXT" . "_.DDEDIT") ("ACDBROTATEDDIMENSION" . "_.DDEDIT") ("ACDBALIGNEDDIMENSION" . "_.DDEDIT") ("ACDBORDINATEDIMENSION" . "_.DDEDIT") ("ACDBDIAMETRICDIMENSION" . "_.DDEDIT") ("ACDBRADIALDIMENSION" . "_.DDEDIT") ("ACDB2LINEANGULARDIMENSION" . "_.DDEDIT") ("ACDBMLINE" . "_.MLEDIT") ("ACDBATTRIBUTEDEFINITION" . "_.DDEDIT") ("ACDBHATCH" . "_.HATCHEDIT") ("ACDBRASTERIMAGE" . "_.IMAGEADJUST") ("AECDBWALL" . "_.PROPERTIES") ("AECDBDOOR" . "_.PROPERTYDATAEDIT") ("AECDBWINDOW" . "_.PROPERTIES") ("AECDBWINDOWASSEMBLY" . "_.PROPERTIES") ("AECDBCURTAINWALLLAYOUT" . "_.PROPERTIES") ("AECDBSPACE" . "_.PROPERTYDATAEDIT") ("AECDBSTAIR" . "_.PROPERTIES") ("AECDBRAILING" . "_.PROPERTIES") ("AECDBMVBLOCKREF" . "_.PROPERTIES") ("AECDBOPENING" . "_.PROPERTIES") ("AECDBCEILINGGRID" . "_.PROPERTIES") ("AECDBCOLUMNGRID" . "_.PROPERTIES") ("AECDBSLAB" . "_.PROPERTIES") ("AECSDBMEMBER" . "_.PROPERTIES") ("AECDBMASSELEM" . "_.PROPERTIES") ("AECDBROOF" . "_.PROPERTIES") ("AECDBROOFSLAB" . "_.PROPERTIES") ("AECDBCAMERA" . "_.PROPERTIES")

clh521 发表于 2009-6-15 19:15:00

具体怎么改？能不能帮忙改下，反应器我一不懂啊

masterlong 发表于 2009-6-15 21:00:00

修改的部分不涉及反应器的知识提取出图块名后判别是否图框块是的话再判别块是否斜角度否的话提取块的包围盒两对角坐标和比例其余的就是打印设置的问题了自己先研究下吧实在不行再帮你改好了

hb_xiaofen 发表于 2009-6-16 22:40:00

回复一下保存下来有时间学学

h008 发表于 2011-7-4 16:35:02

好好学习下！

宏远电脑学校 发表于 2011-9-29 23:54:16

CAD2008打开“工具”“自定义”“界面”里面有双击块设置，默认是宏，你设成LISP函数名就行了，比如：定义（defun c:test()，就填上test就行了，记得加载LISP程序哦。

mmh1 发表于 2011-10-2 15:00:45

只听说反应器，还没涉及！观望学习下

我爱lisp 发表于 2014-9-26 15:22:06

(vl-load-com)
(if (not (tblsearch "layer" "HATCH"))
(command "-layer" "m" "HATCH" "c" "254" "" "l" "continuous" "" "")
) ;加载图层HATCH
(if (not *dblclkReactor*)
(setq *dblclkReactor*
(VLR-Mouse-Reactor
 nil
 '((:VLR-beginDoubleClick . dblclkedit))
)
)
) ;0 = 打开反应器
(defun dblclkedit (reactorObject point)
(if dblclk-edit
(dblclk-edit point)
)
)
(defun dblclk-edit (dblclk_point / owner dblclk_etype p)
(setq owner (nentselp (setq p (trans (car dblclk_point) 0 1))))
;指定点来选择对象
(if (and (= owner nil) (= 0 (getvar 'cmdactive))) ;_有活动命令时不起作用
(vla-sendcommand
 (vla-get-activedocument (vlax-get-acad-object))
 (strcat (rtos (car p) 2 3)
 ","
 (rtos (cadr p) 2 3)
 " tianc "
 )
)
)
)
(defun c:tianc (/ opt pt la)
(setvar "measurement" 1)
(setq opt
(mycadgetkword
 "\n①实体/②钢筋砼/③素砼/④墙体/⑤阳台/⑥卫生间/⑦厨房：<1>"
 '("1" "2" "3" "4" "5" "6" "7")
 "1"
)
)
(cond
((= opt "1") (tianchong1))
((= opt "2") (tianchong2))
((= opt "3") (tianchong3))
((= opt "4") (tianchong4))
((= opt "5") (tianchong5))
((= opt "6") (tianchong6))
((= opt "7") (tianchong7))
)
(princ)
)

(defun tianchong1 ()
(prompt "\n实体填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "solid" pt "")
)
(setvar "clayer" la)
) ;solid连续填充,指定内部点

(defun tianchong2 ()
(prompt "\n钢筋砼填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "ar-conc" "4" "0" pt "")
(command "bhatch" "p" "ansi31" "160" "0" "@" "")
)
(setvar "clayer" la)
) ;ar-conc&ansi31连续填充,指定内部点

(defun tianchong3 ()
(prompt "\n素砼填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "ar-conc" "4" "0" pt "")
)
(setvar "clayer" la)
) ;ar-conc连续填充,指定内部点

(defun tianchong4 ()
(prompt "\n墙体填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "ansi31" "60" "0" pt "")
)
(setvar "clayer" la)
) ;ansi31连续填充,指定内部点

(defun tianchong5 ()
(prompt "\n阳台填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "ansi37" "60" "0" pt "")
)
(setvar "clayer" la)
) ;ansi37连续填充,指定内部点

(defun tianchong6 ()
(prompt "\n卫生间填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "cross" "30" "0" pt "")
)
(setvar "clayer" la)
) ;cross连续填充,指定内部点

(defun tianchong7 ()
(prompt "\n厨房填充,指定内部点\n")
(setq la (getvar "clayer"))
(command "layer" "s" "hatch" "")
(while (setq pt (getpoint))
(command "bhatch" "p" "angle" "30" "0" pt "")
)
(setvar "clayer" la)
) ;angle连续填充,指定内部点
(princ)

(defun MycadGetkword (pro lst def / kw val)
(setq lst (apply
 'append
 (mapcar '(lambda (e)
(list (ascii (strcase e)) (ascii (strcase e T)))
 )
 lst
 )
 )
def (ascii def)
)
(prompt pro)
(while (not (and (setq kw(grread nil)
val (car kw)
kw(cadr kw)
 )
 (member val '(2 11 25))
 (if (or (= val 25)
 (and (= val 11) (= kw 0))
 (member kw '(13 32))
 )
 (setq kw def)
 (member kw lst)
 )
 )
)
)
(strcase (vl-list->string (list kw)))
)

我爱lisp 发表于 2014-9-26 15:22:51

这个双击反应器可以直接运行，你可以慢慢研究，看看如何修改

页: [1]

明经CAD社区's Archiver

[求助]如何双击一个块，就执行一个指定的lisp程序？