求高手修改一下动态线型比例！！！

lingduwx

在论坛下载了848818376 的test动态改变线型比例感觉非常好，现在求高手修改一下，
去掉那个对话框，将他改为命令行方式更方便，让命令行显示“单独线型修改d,全局线型修改q，默认d”
另外当选择全局线修改时，选中的哪几种线，就修改哪几种线型的全局比例，没有选中的线型不做修改，
小弟先谢了

   附件在楼下

lingduwx

上面忘了提供LSP了
附件在此

清风明月名字

谢谢楼主代码分享！期待高手出手

llsheng_73

lingduwx 发表于 2013-9-28 10:56
上面忘了提供LSP了
附件在此

只是需要去除对话框？
那样的话就改主程序就行了

1. (defun C:xx ( / userclick temp)
   
2.   (vl-load-com)
   
3.   (setq temp (getvar "cmdecho"))
   
4.   (setvar "cmdecho" 0)
   
5.   (command "undo" "be")
   
6.   (while (not(member userclick'("d""D""q""Q""")))
   
7.     (setq userclick(getstring"\n单独线型修改d,全局线型修改q<d>")))
   
8.   (if (=""userclick)(setq userclick"d"))
   
9.   (cond ((member userclick'("d""D"))(qjchenedltscale 1))
   
10.         ((member userclick'("q""Q"))(qjchenedltscale 2))
    
11.   )
    
12.   (command "undo" "e")
    
13.   (setvar "cmdecho" temp)
    
14. )
    
15. ;;只修改了主程序部分，下边两个函数均直接复制原附件里边的，没有对其进行过测试，因为相信你呗
    
16. (defun qjchenedltscale(n / a b gr linetype newscale o orilst overallltscale zq)
    
17.   (prompt "\n 请选择某一非continuous线型的物体:")
    
18.   (setq a (car (entsel)) o (vlax-ename->vla-object a))
    
19.   (setq orilst (vlax-get-property o 'LinetypeScale))
    
20.   (setq linetype (cdr (assoc 6 (entget a))))
    
21.   (if (= linetype nil)
    
22.       (setq linetype (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 (entget a)))))))
    
23.   )
    
24.   (if (and linetype (/= linetype "Continuous"))
    
25.     (progn  
    
26.       (setq zq (cdr (assoc 40 (tblsearch "ltype" linetype))))
    
27.       (setq overallltscale (getvar "LTSCALE"))
    
28.       (setq b (getpoint "\n请选择一个点:"))
    
29.       (while (= (car (setq gr (grread nil 5 0))) 5)
    
30. (redraw)
    
31. (grdraw (cadr gr) b 1 1)
    
32. (setq newscale (/ (distance (cadr gr) b) zq overallltscale))
    
33. (apply-props o (list (list "LinetypeScale" newscale)))
    
34.       )
    
35.       (if (= n 2)
    
36. (progn
    
37.    (setvar "ltscale" (* overallltscale (/ newscale orilst)))
    
38.    (apply-props o (list (list "LinetypeScale" orilst)))
    
39.    (command "regen")
    
40. )
    
41.       )
    
42.     )
    
43.   )
    
44.   (vlax-release-object o)
    
45.   (princ)
    
46. )
    
47. (defun apply-props (object proplist)
    
48.   (foreach prop proplist
    
49.     (if (vlax-property-available-p object (car prop))
    
50.       (vlax-put-property object (car prop) (cadr prop))
    
51.     )
    
52.   )
    
53. )
    
54. 
    

(defun C:xx ( / userclick temp)<br />   (vl-load-com)<br />   (setq temp (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   (command "undo" "be")<br />   (while (not(member userclick'("d""D""q""Q""")))<br />     (setq userclick(getstring"\n单独线型修改d,全局线型修改q<d>")))<br />   (if (=""userclick)(setq userclick"d"))<br />   (cond ((member userclick'("d""D"))(qjchenedltscale 1))<br />         ((member userclick'("q""Q"))(qjchenedltscale 2))<br />   )<br />   (command "undo" "e")<br />   (setvar "cmdecho" temp)<br /> )<br /> ;;只修改了主程序部分，下边两个函数均直接复制原附件里边的，没有对其进行过测试，因为相信你呗<img src="static/image/smiley/qq/em18.gif" smilieid="426" border="0" alt="" /><br /> (defun qjchenedltscale(n / a b gr linetype newscale o orilst overallltscale zq)<br />   (prompt "\n 请选择某一非continuous线型的物体:")<br />   (setq a (car (entsel)) o (vlax-ename->vla-object a))<br />   (setq orilst (vlax-get-property o 'LinetypeScale))<br />   (setq linetype (cdr (assoc 6 (entget a))))<br />   (if (= linetype nil) <br />       (setq linetype (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 (entget a)))))))<br />   )<br />   (if (and linetype (/= linetype "Continuous"))<br />     (progn  <br />       (setq zq (cdr (assoc 40 (tblsearch "ltype" linetype))))<br />       (setq overallltscale (getvar "LTSCALE"))<br />       (setq b (getpoint "\n请选择一个点:"))<br />       (while (= (car (setq gr (grread nil 5 0))) 5)<br /> (redraw)<br /> (grdraw (cadr gr) b 1 1)<br /> (setq newscale (/ (distance (cadr gr) b) zq overallltscale))<br /> (apply-props o (list (list "LinetypeScale" newscale)))<br />       )<br />       (if (= n 2)<br /> (progn<br />    (setvar "ltscale" (* overallltscale (/ newscale orilst)))<br />    (apply-props o (list (list "LinetypeScale" orilst)))<br />    (command "regen")<br /> )<br />       )<br />     )<br />   )<br />   (vlax-release-object o)<br />   (princ)<br /> )<br /> (defun apply-props (object proplist)<br />   (foreach prop proplist<br />     (if (vlax-property-available-p object (car prop))<br />       (vlax-put-property object (car prop) (cadr prop))<br />     )<br />   )<br /> )<br /> <br />

lingduwx

llsheng_73 发表于 2013-10-24 13:22
只是需要去除对话框？
那样的话就改主程序就行了

非常感谢兄弟，偶马上用一下，呵呵

lingduwx

llsheng_73 发表于 2013-10-24 13:22
只是需要去除对话框？
那样的话就改主程序就行了

大哥你好，不知道为什么，我用的时候出现错误啊，麻烦再帮忙看看嘛

命令: xx
单独线型修改d,全局线型修改q<d>d
; 错误: no function definition: QJCHENEDLTSCALE
命令: xx
单独线型修改d,全局线型修改q<d>q
; 错误: no function definition: QJCHENEDLTSCALE

llsheng_73

你原来那程序的别的部分还得一起啊，老大

lingduwx

llsheng_73 发表于 2013-10-27 10:25
你原来那程序的别的部分还得一起啊，老大

麻烦兄弟帮忙弄一下嘛，偶实在是不懂LSP，谢谢了

llsheng_73

lingduwx 发表于 2013-10-27 10:29
麻烦兄弟帮忙弄一下嘛，偶实在是不懂LSP，谢谢了

哪个程序修改过了就替换掉哪一部分，哪些没用了就删掉它，别的留下，这不就是剪刀手的干活而已么

前边的程序已经给你弄好了
没有测试，只是按你的要求去了对话框。。。具体能不能实现，关键在后边几个原有的函数上班

lingduwx

llsheng_73 发表于 2013-10-27 11:36
哪个程序修改过了就替换掉哪一部分，哪些没用了就删掉它，别的留下，这不就是剪刀手的干活而已么
...

非常感谢兄弟！
可以再麻烦哈兄弟吗？
就是修改全局比例的时候，先选中几种线型，然后就只修改这几种线型的比例