test动态改变线型比例

848818376

test动态改变线型比例，详见附件图片及录像

该贴已经同步到 848818376的微博

848818376

没人喜欢啊？

zyhandw

帮你顶个吧

love12314

帮你顶个

杨如迁

848818376

感谢前辈

tianyi1230

论坛里面有动态改变线形比例的

sachindkini

Dear sir,
qjchen all ready share free version

2. ;;; dynamic  by qjchen@gmail.com
   
3. ;;; The mail idea come from eachy master:  http://eachy.bokee.com/5731665.html
   
4. ;;; http://www.xdcad.net/forum/showthread.php?postid=1534283
   
5. 
   
6. (defun C:test ( / dcl_id dclcontent dclname userclick temp)
   
7.   (vl-load-com)
   
8.   (setq temp (getvar "cmdecho"))
   
9.   (setvar "cmdecho" 0)
   
10.   (command "undo" "be")
    
11.   (setq dclcontent (list
    
12.            "qjchenedynamicltscale:dialog{"
    
13.            "label="dynamic linetype scale modify by qjchen";"
    
14.            ":button{"
    
15.                 "key = "button1";"
    
16.                 "label = "individual object ltscale";}"
    
17.            ":button{"
    
18.                 "key = "button2";"
    
19.                 "label = "overall ltscale";}"
    
20.            "ok_cancel;}")
    
21.   dclname "qjchendltscale"
    
22.   )
    
23.   (setq dcl_id (load_dialog (qjchencreatdcl dclname dclcontent)))
    
24.   (if (not (new_dialog "qjchenedynamicltscale" dcl_id)) (exit))
    
25.   (action_tile "button1" "(done_dialog 3)")
    
26.   (action_tile "button2" "(done_dialog 4)")
    
27.   (setq userclick (start_dialog))
    
28.   (unload_dialog dcl_id)
    
29.   (cond ((= 3 userclick)(qjchenedltscale 1))
    
30.         ((= 4 userclick)(qjchenedltscale 2))
    
31.   )
    
32.   (command "undo" "e")
    
33.   (setvar "cmdecho" temp)
    
34. )
    
35. 
    
36. (defun qjchenedltscale(n / a b gr linetype newscale o orilst overallltscale zq)
    
37.   (prompt "\n Please select one not continuous linetype object:")
    
38.   (setq a (car (entsel)) o (vlax-ename->vla-object a))
    
39.   (setq orilst (vlax-get-property o 'LinetypeScale))
    
40.   (setq linetype (cdr (assoc 6 (entget a))))
    
41.   (if (= linetype nil)
    
42.       (setq linetype (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 (entget a)))))))
    
43.   )
    
44.   (if (and linetype (/= linetype "Continuous"))
    
45.     (progn  
    
46.       (setq zq (cdr (assoc 40 (tblsearch "ltype" linetype))))
    
47.       (setq overallltscale (getvar "LTSCALE"))
    
48.       (setq b (getpoint "\nSelect one point:"))
    
49.       (while (= (car (setq gr (grread nil 5 0))) 5)
    
50.         (redraw)
    
51.         (grdraw (cadr gr) b 1 1)
    
52.         (setq newscale (/ (distance (cadr gr) b) zq overallltscale))
    
53.         (apply-props o (list (list "LinetypeScale" newscale)))
    
54.       )
    
55.       (if (= n 2)
    
56.         (progn
    
57.           (setvar "ltscale" (* overallltscale (/ newscale orilst)))
    
58.           (apply-props o (list (list "LinetypeScale" orilst)))
    
59.           (command "regen")
    
60.         )
    
61.       )
    
62.     )
    
63.   )
    
64.   (vlax-release-object o)
    
65.   (princ)
    
66. )
    
67. 
    
68. ;;from dave theswamp
    
69. (defun apply-props (object proplist)
    
70.   (foreach prop proplist
    
71.     (if (vlax-property-available-p object (car prop))
    
72.       (vlax-put-property object (car prop) (cadr prop))
    
73.     )
    
74.   )
    
75. )
    
76. 
    
77. (defun qjchencreatdcl(dclname lst)
    
78. (setq dcl_name (strcat (getenv "temp") "\" dclname ".dcl")
    
79.         f (OPEN dcl_name "w")
    
80.   )
    
81.   (foreach x lst
    
82.      (write-line x f)
    
83.    )
    
84.   (close f)
    
85.   dcl_name
    
86. )
    
87. 
    
88. ;;end main program
    
89. (princ "\n By qjchen@gmail.com, dynamic linescale, The command is test")
    
90. (princ)
    

;;; dynamic  by qjchen@gmail.com<br /> ;;; The mail idea come from eachy master:  http://eachy.bokee.com/5731665.html<br /> ;;; http://www.xdcad.net/forum/showthread.php?postid=1534283<br /> <br /> (defun C:test ( / dcl_id dclcontent dclname userclick temp)<br />   (vl-load-com)<br />   (setq temp (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   (command "undo" "be")<br />   (setq dclcontent (list <br />            "qjchenedynamicltscale:dialog{"<br />            "label="dynamic linetype scale modify by qjchen";"<br />            ":button{" <br />                 "key = "button1";"<br />                 "label = "individual object ltscale";}"<br />            ":button{" <br />                 "key = "button2";"<br />                 "label = "overall ltscale";}"<br />            "ok_cancel;}")<br />   dclname "qjchendltscale"<br />   )<br />   (setq dcl_id (load_dialog (qjchencreatdcl dclname dclcontent))) <br />   (if (not (new_dialog "qjchenedynamicltscale" dcl_id)) (exit))<br />   (action_tile "button1" "(done_dialog 3)")<br />   (action_tile "button2" "(done_dialog 4)")<br />   (setq userclick (start_dialog))<br />   (unload_dialog dcl_id)<br />   (cond ((= 3 userclick)(qjchenedltscale 1))<br />         ((= 4 userclick)(qjchenedltscale 2))<br />   )<br />   (command "undo" "e")<br />   (setvar "cmdecho" temp)<br /> )<br /> <br /> (defun qjchenedltscale(n / a b gr linetype newscale o orilst overallltscale zq)<br />   (prompt "\n Please select one not continuous linetype object:")<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 "\nSelect one point:"))<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 /> <br /> ;;from dave theswamp<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 /> (defun qjchencreatdcl(dclname lst)<br /> (setq dcl_name (strcat (getenv "temp") "\" dclname ".dcl")<br />         f (OPEN dcl_name "w")<br />   )<br />   (foreach x lst<br />      (write-line x f)<br />    )<br />   (close f)<br />   dcl_name<br /> )<br /> <br /> ;;end main program<br /> (princ "\n By qjchen@gmail.com, dynamic linescale, The command is test")<br /> (princ)<br />

[