按色选择与动态线型比例的完美结合，（作者zhynt大师）

669423907

如题所述，以下分别是 “按色选择对象” 程序与 “动态修改线型比例”程序，如何合并呢？
;选择相同类型、相同图层、相同颜色的（全部）对象 ( zml84 于 2009-03-28)
(defun C:sxs(/ SS ENT LST)
(if (setq SS (entsel "\n点取对象:"))
(progn
;获取对象组码列表
(setq ENT (entget (car SS)))
;创建过滤列表
(if (assoc 62 ENT)
(setq LST (list (assoc 62 ENT)))
(setq LST (list (cons 62 256))))
(setq LST (cons (assoc 8 ENT) LST)
LST (cons (assoc 0 ENT) LST))
;筛选对象
(setq SS (ssget LST));选择全部ssget "x" LST
;显示信息
(princ (strcat "\n**共选择到 "
(itoa (sslength SS)) " 个对象。"))
;设置为当前选择
(sssetfirst NIL SS)))
(princ))



动态修改线型比例（zhynt）2011-6-23 02:07
(defun c:sf(/ ss alts pt gr s1 lt newscale)
;(prompt "\n请选择非Contiiuous线型: ")
(setq ss (ssget) alts (getvar "LTSCALE") pt (getpoint "\n请指定一个点: "))
(while (= (car (setq gr (grread nil 5 0))) 5)
(redraw)(grdraw (cadr gr) pt 1 1)(setq i -1)
(while (setq s1 (ssname ss (setq i (1  i))))
(if (setq lt (cdr (assoc 6 (entget s1))))(progn
(setq zq (cdr (assoc 40 (tblsearch "ltype" lt))))
(if (/= zq 0)
(setq newscale (/ (distance (cadr gr) pt) zq alts 1.))
(setq newscale 1)))
(progn (setq zq (cdr (assoc 40 (tblsearch "ltype"
(cdr (assoc 6
(tblsearch "layer" (cdr (assoc 8 (entget s1))))))))))
(if (/= zq 0)(setq newscale (/ (distance (cadr gr) pt) zq alts 1.))
(setq newscale 1))))
(vla-put-LinetypeScale (vlax-ename->vla-object s1) newscale)))
(redraw)(princ))

zhynt

ok,好了。不用按什么快捷键。

ziyouwzb

(while (setq s1 (ssname ss (setq i (1  i))))
应该改为(while (setq s1 (ssname ss (setq i (1+  i))))

184632152

zhynt 发表于 2011-7-22 11:27
回复 pb.v@163.com 的帖子

大神！可以把这个改成先填充指定图案再动态调整填充比例吗？

zhynt

2. 
   
3. (defun C:sxs (/ SS ENT LST)
   
4.   (if (setq SS (entsel "\n点取对象:"))
   
5.     (progn
   
6.       (setq ENT (entget (car SS)))
   
7.       (if (assoc 62 ENT)
   
8.         (setq LST (list (assoc 62 ENT)))
   
9.         (setq LST (list (cons 62 256)))
   
10.       )
    
11.       (setq LST        (cons (assoc 8 ENT) LST)
    
12.             LST        (cons (assoc 0 ENT) LST)
    
13.       )
    
14.       (setq SS (ssget LST))
    
15.     )                                        ;选择全部ssget "x" LST
    
16.   )
    
17.   (setq        alts (getvar "LTSCALE")
    
18.         pt   (getpoint "\n请指定一个点: ")
    
19.   )
    
20.   (while (= (car (setq gr (grread nil 5 0))) 5)
    
21.     (redraw)
    
22.     (grdraw (cadr gr) pt 1 1)
    
23.     (setq i -1)
    
24.     (while (setq s1 (ssname ss (setq i (1+ i))))
    
25.       (if (setq lt (cdr (assoc 6 (entget s1))))
    
26.         (progn
    
27.           (setq zq (cdr (assoc 40 (tblsearch "ltype" lt))))
    
28.           (if (/= zq 0)
    
29.             (setq newscale (/ (distance (cadr gr) pt) zq alts 1.))
    
30.             (setq newscale 1)
    
31.           )
    
32.         )
    
33.         (progn (setq zq
    
34.                       (cdr
    
35.                         (assoc
    
36.                           40
    
37.                           (tblsearch
    
38.                             "ltype"
    
39.                             (cdr
    
40.                               (assoc
    
41.                                 6
    
42.                                 (tblsearch "layer" (cdr (assoc 8 (entget s1))))
    
43.                               )
    
44.                             )
    
45.                           )
    
46.                         )
    
47.                       )
    
48.                )
    
49.                (if (/= zq 0)
    
50.                  (setq newscale (/ (distance (cadr gr) pt) zq alts 1.))
    
51.                  (setq newscale 1)
    
52.                )
    
53.         )
    
54.       )
    
55.       (vla-put-LinetypeScale (vlax-ename->vla-object s1) newscale)
    
56.     )
    
57.   )
    
58.   (redraw)
    
59.   (princ)
    
60. )
    

<br /> (defun C:sxs (/ SS ENT LST)<br />   (if (setq SS (entsel "\n点取对象:"))<br />     (progn<br />       (setq ENT (entget (car SS)))<br />       (if (assoc 62 ENT)<br />         (setq LST (list (assoc 62 ENT)))<br />         (setq LST (list (cons 62 256)))<br />       )<br />       (setq LST        (cons (assoc 8 ENT) LST)<br />             LST        (cons (assoc 0 ENT) LST)<br />       )<br />       (setq SS (ssget LST))<br />     )                                        ;选择全部ssget "x" LST<br />   )<br />   (setq        alts (getvar "LTSCALE")<br />         pt   (getpoint "\n请指定一个点: ")<br />   )<br />   (while (= (car (setq gr (grread nil 5 0))) 5)<br />     (redraw)<br />     (grdraw (cadr gr) pt 1 1)<br />     (setq i -1)<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (if (setq lt (cdr (assoc 6 (entget s1))))<br />         (progn<br />           (setq zq (cdr (assoc 40 (tblsearch "ltype" lt))))<br />           (if (/= zq 0)<br />             (setq newscale (/ (distance (cadr gr) pt) zq alts 1.))<br />             (setq newscale 1)<br />           )<br />         )<br />         (progn (setq zq<br />                       (cdr<br />                         (assoc<br />                           40<br />                           (tblsearch<br />                             "ltype"<br />                             (cdr<br />                               (assoc<br />                                 6<br />                                 (tblsearch "layer" (cdr (assoc 8 (entget s1))))<br />                               )<br />                             )<br />                           )<br />                         )<br />                       )<br />                )<br />                (if (/= zq 0)<br />                  (setq newscale (/ (distance (cadr gr) pt) zq alts 1.))<br />                  (setq newscale 1)<br />                )<br />         )<br />       )<br />       (vla-put-LinetypeScale (vlax-ename->vla-object s1) newscale)<br />     )<br />   )<br />   (redraw)<br />   (princ)<br /> )<br />

669423907

回复 zhynt 的帖子

哈哈，又是你吖，zhynt 大师，非常感谢啦。
刚才用了你改的程序，感觉很好用。
现在有一个疑问：可不可以多加一个功能

在选择对象之后，在右键确认之前，如果按了一个命令（如m，mi，s，或者其他 lsp 的快捷键）再右键确认，就执行这个命令，不执行修改线型比例的命令。否则就执行修改线型比例命令。

此完美程序，就有劳 zhynt 大师啦！

669423907

手机上下不了！晚上先！再次感谢 zhynt 大师！

simon8001

已经给你解决了呀！！

669423907

回复 zhynt 的帖子

程序非常好，非常完美，非常给力！非常非常感谢 zhynt 大师非常非常热情的帮助！

cjjh8301

收藏了，谢谢！

andyzha

回复 zhynt 的帖子

是这样的，我现在用的工具插件里就有这样动态调整线性比例和填充比例的，zhynt 大师能修改一下可以调整线性比例和填充比例通用的LSP吗？不胜感谢您无私的分享精神！

yjr111

真是完美程序！牛！！