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

669423907

小生愚笨，不会改，请大师们帮帮忙，先谢了。
求改不能选择 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)
)

功夫佬

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

zhynt

2. 
   
3. (defun c:bbl (/ ss alts pt gr s1 lt newscale)
   
4.   (prompt "\n 请选择物体: ")
   
5.   (setq        ss   (ssget)
   
6.         alts (getvar "LTSCALE")
   
7.         pt   (getpoint "\n请选择一个点: ")
   
8.   )
   
9.   (while (= (car (setq gr (grread nil 5 0))) 5)
   
10.     (redraw)
    
11.     (grdraw (cadr gr) pt 1 1)
    
12.     (setq i -1)
    
13.     (while (setq s1 (ssname ss (setq i (1+ i))))
    
14.       (if (setq lt (cdr (assoc 6 (entget s1))))
    
15.         (progn
    
16.           (setq zq (cdr (assoc 40 (tblsearch "ltype" lt))))
    
17.           (if (/= zq 0)
    
18.             (setq newscale (/ (distance (cadr gr) pt) zq alts 1.))
    
19.             (setq newscale 1)
    
20.           )
    
21.         )
    
22.         (progn
    
23.           (setq        zq
    
24.                  (cdr
    
25.                    (assoc
    
26.                      40
    
27.                      (tblsearch
    
28.                        "ltype"
    
29.                        (cdr
    
30.                          (assoc
    
31.                            6
    
32.                            (tblsearch "layer" (cdr (assoc 8 (entget s1))))
    
33.                          )
    
34.                        )
    
35.                      )
    
36.                    )
    
37.                  )
    
38.           )
    
39.           (if (/= zq 0)
    
40.             (setq newscale (/ (distance (cadr gr) pt) zq alts 1.))
    
41.             (setq newscale 1)
    
42.           )
    
43.         )
    
44.       )
    
45.       (vla-put-LinetypeScale (vlax-ename->vla-object s1) newscale)
    
46.     )
    
47.   )
    
48.   (redraw)
    
49.   (princ)
    
50. )
    

<br /> (defun c:bbl (/ ss alts pt gr s1 lt newscale)<br />   (prompt "\n 请选择物体: ")<br />   (setq        ss   (ssget)<br />         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<br />           (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 />

zhynt

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

669423907

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

caoxinheng

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

guankuiwu

很好！解决问题了！感谢