669423907 发表于 2011-6-22 23:37:52

改不能选择 ByLayer 线型的修改线型比例的程序（已解决多谢zhynt大师帮助）

本帖最后由 669423907 于 2011-6-26 18:29 编辑

小生愚笨，不会改，请大师们帮帮忙，先谢了。
求改不能选择 ByLayer 线型的修改线型比例的程序

动态修改线型比例
(defun c:bbl(/ ss alts pt gr s1 lt zq newscale)
(prompt "\n 请选择物体: ")
(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)))
newscale (/ (distance (cadr gr) pt) zq alts 1.)
)
(vla-put-LinetypeScale (vlax-ename->vla-object s1) newscale)
)
      )
    )
)
(redraw)
(princ)
)

功夫佬 发表于 2012-5-24 23:53:22

能否将这个点去除，pt   (getpoint "\n请选择一个点: ")
只用选择自动调整。如图所示

zhynt 发表于 2011-6-23 01:30:27

本帖最后由 zhynt 于 2011-6-23 02:07 编辑


(defun c:bbl (/ ss alts pt gr s1 lt newscale)
(prompt "\n 请选择物体: ")
(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 发表于 2011-6-23 02:16:28

因随层的线型没有组码6，所以原程序将其跳过去了。现在我新加了判断，当随层时，找其所在的图层，通过图层来确定线型。又实线的组码40的值为0，程序将出错（除数为零）所以再加以判断如果为0，将newscale的值置为1

669423907 发表于 2011-6-23 11:30:54

本帖最后由 669423907 于 2011-6-23 11:32 编辑

非常感谢你的热情帮助！
大师，要注意休息吖。

caoxinheng 发表于 2011-7-6 15:27:30

终于完美解决了线型比例问题

guankuiwu 发表于 2022-5-13 16:02:52

很好！解决问题了！感谢
页: [1]
查看完整版本: 改不能选择 ByLayer 线型的修改线型比例的程序（已解决多谢zhynt大师帮助）