669423907 发表于 2011-6-27 23:15:47

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

本帖最后由 669423907 于 2011-7-6 07:47 编辑

如题所述，以下分别是 “按色选择对象” 程序与 “动态修改线型比例”程序，如何合并呢？
;选择相同类型、相同图层、相同颜色的（全部）对象 ( 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 (1i))))
(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 发表于 2011-6-28 12:52:25

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

ziyouwzb 发表于 2023-10-24 20:44:51

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

184632152 发表于 2021-5-30 15:43:00

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

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

zhynt 发表于 2011-6-27 23:47:22


(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
)
(setq        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)
)

669423907 发表于 2011-6-28 11:50:09

标题

回复 zhynt 的帖子

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

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

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

669423907 发表于 2011-6-28 14:02:19

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

simon8001 发表于 2011-6-28 15:01:13

已经给你解决了呀！！

669423907 发表于 2011-6-29 08:08:53

标题

回复 zhynt 的帖子

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

cjjh8301 发表于 2011-6-29 10:23:05

收藏了，谢谢！

andyzha 发表于 2011-6-29 22:41:02

回复 zhynt 的帖子

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

yjr111 发表于 2011-7-4 09:32:54

真是完美程序！牛！！
页: [1] 2 3 4 5 6
查看完整版本: 按色选择与动态线型比例的完美结合，（作者zhynt大师）