[求助]写个小程序(这个对我来说很实用)

he520930

求你写一个简单而实用的小程序:
用法:运行命令---点选某图纸中任一对象文字(目的是读取这个文字的颜色)---然后框选图形或整个图形(就可以把刚才点选的文字相同颜色的文字全部选了)----然后回车----点起点(复制文字起点)---点终点(复制相同文字终点)就行了.
总的来说:就是读取文字颜色来复制框选中相同颜色的文字的小程序.本来我可以用CAD
本身的"快速选择"的功能就可以了,但图形太大,用这个"快速选择"运行得太慢,希望热心人能帮助一下.谢谢了!

BDYCAD

2. ;;;编程:BDYCAD   时间:20071110
3. (defun c:test(/ BASCOLOR COLORSEL ENAME I II MOVEEPT MOVESPT NEW-VLNAME P1 P2 SS VLNAME)
4.   (if(setq Ename(car(entsel"\n请选择对象：")))
5.     (if(setq p1(getpoint"\n请输入起点："))
6.       (if(setq p2(getpoint p1"\n请全入终点："))
7. (progn
8.    (setq BasColor(vla-get-color(vlax-ename->vla-object Ename))
9.   ColorSel(cons 62 BasColor)
10.   )
11.    (if(setq SS(ssget"X"(list ColorSel(cons 0 "TEXT"))))
12.      (progn
13.        (setq i 0)
14.        (setq MoveSpt(vlax-3d-point p1)MoveEpt(vlax-3d-point p2))
15.        (repeat(sslength ss)
16.   (setq Ename(ssname ss i)
17.         Vlname(vlax-ename->vla-object Ename)
18.         New-Vlname(vla-copy Vlname))
19.   (vla-move New-Vlname MoveSpt MoveEpt)
20.   (setq i(1+ ii)))
21.        )
22.      )
23.    )
24. )
25.       )
26.     )
27.   (princ)
28.   )

;;;编程:BDYCAD   时间:20071110 (defun c:test(/ BASCOLOR COLORSEL ENAME I II MOVEEPT MOVESPT NEW-VLNAME P1 P2 SS VLNAME)   (if(setq Ename(car(entsel"\n请选择对象：")))     (if(setq p1(getpoint"\n请输入起点："))       (if(setq p2(getpoint p1"\n请全入终点：")) (progn    (setq BasColor(vla-get-color(vlax-ename->vla-object Ename))   ColorSel(cons 62 BasColor)   )    (if(setq SS(ssget"X"(list ColorSel(cons 0 "TEXT"))))      (progn        (setq i 0)        (setq MoveSpt(vlax-3d-point p1)MoveEpt(vlax-3d-point p2))        (repeat(sslength ss)   (setq Ename(ssname ss i)         Vlname(vlax-ename->vla-object Ename)         New-Vlname(vla-copy Vlname))   (vla-move New-Vlname MoveSpt MoveEpt)   (setq i(1+ ii)))        )      )    ) )       )     )   (princ)   )

BDYCAD

1. 改一下程序运行顺序!!!!

复制代码

[code];;;编程:BDYCAD   时间:20071110 (defun c:test(/ BASCOLOR ENAME I MOVEEPT MOVESPT NEW-VLNAME P1 P2 SS VLNAME)   (if(setq SS(ssget'((0 . "TEXT"))))    (if(setq Ename(car(entsel"\n请选择对象：")))      (if(setq p1(getpoint"\n请输入起点："))        (if(setq p2(getpoint p1"\n请全入终点："))   (progn     (setq BasColor(vla-get-color(vlax-ename->vla-object Ename)) )     (progn         (setq i 0)         (setq MoveSpt(vlax-3d-point p1)MoveEpt(vlax-3d-point p2))         (repeat(sslength ss)    (setq Ename(ssname ss i)   Vlname(vlax-ename->vla-object Ename)   )    (if(=(vla-get-color Vlname)BasColor)      (progn        (setq New-Vlname(vla-copy Vlname))        (vla-move New-Vlname MoveSpt MoveEpt)        ))    (setq i(1+ i)))         )     )   )        )      )     )    (princ)    ) [/code]

hydkot99

错误: no function definition: VLAX-ENAME->VLA-OBJECT