动态修改线型比例

Lisphk · 发表于 2021-1-19 10:56:16

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;; dynamic by qjchen@gmail.com
;;; The mail idea come from eachy master: http://eachy.bokee.com/5731665.html
;;; http://www.xdcad.net/forum/showthread.php?postid=1534283
(defun C:test ( / dcl_id dclcontent dclname userclick temp)
(vl-load-com)
(setq temp (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "undo" "be")
(setq dclcontent (list
"qjchenedynamicltscale:dialog{"
"label=\"dynamic linetype scale modify by qjchen\";"
":button{"
"key = \"button1\";"
"label = \"individual object ltscale\";}"
":button{"
"key = \"button2\";"
"label = \"overall ltscale\";}"
"ok_cancel;}")
dclname "qjchendltscale"
)
(setq dcl_id (load_dialog (qjchencreatdcl dclname dclcontent)))
(if (not (new_dialog "qjchenedynamicltscale" dcl_id)) (exit))
(action_tile "button1" "(done_dialog 3)")
(action_tile "button2" "(done_dialog 4)")
(setq userclick (start_dialog))
(unload_dialog dcl_id)
(cond ((= 3 userclick)(qjchenedltscale 1))
((= 4 userclick)(qjchenedltscale 2))
)
(command "undo" "e")
(setvar "cmdecho" temp)
)
(defun qjchenedltscale(n / a b gr linetype newscale o orilst overallltscale zq)
(prompt "\n Please select one not continuous linetype object:")
(setq a (car (entsel)) o (vlax-ename->vla-object a))
(setq orilst (vlax-get-property o 'LinetypeScale))
(setq linetype (cdr (assoc 6 (entget a))))
(if (= linetype nil)
(setq linetype (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 (entget a)))))))
)
(if (and linetype (/= linetype "Continuous"))
(progn
(setq zq (cdr (assoc 40 (tblsearch "ltype" linetype))))
(setq overallltscale (getvar "LTSCALE"))
(setq b (getpoint "\nSelect one point:"))
(while (= (car (setq gr (grread nil 5 0))) 5)
(redraw)
(grdraw (cadr gr) b 1 1)
(setq newscale (/ (distance (cadr gr) b) zq overallltscale))
(apply-props o (list (list "LinetypeScale" newscale)))
)
(if (= n 2)
(progn
(setvar "ltscale" (* overallltscale (/ newscale orilst)))
(apply-props o (list (list "LinetypeScale" orilst)))
(command "regen")
)
)
)
)
(vlax-release-object o)
(princ)
)
;;from dave theswamp
(defun apply-props (object proplist)
(foreach prop proplist
(if (vlax-property-available-p object (car prop))
(vlax-put-property object (car prop) (cadr prop))
)
)
)
(defun qjchencreatdcl(dclname lst)
(setq dcl_name (strcat (getenv "temp") "\\" dclname ".dcl")
f (OPEN dcl_name "w")
)
(foreach x lst
(write-line x f)
)
(close f)
dcl_name
)
;;end main program
(princ "\n By qjchen@gmail.com, dynamic linescale, The command is test")
(princ)

;;; dynamic  by <a href=\"mailto:qjchen@gmail.com\">qjchen@gmail.com</a> 
;;; The mail idea come from eachy master:  <a href=\"http://eachy.bokee.com/5731665.html\" target=\"_blank\">http://eachy.bokee.com/5731665.html</a> 
;;; <a href=\"http://www.xdcad.net/forum/showthread.php?postid=1534283\" target=\"_blank\">http://www.xdcad.net/forum/showthread.php?postid=1534283</a> 
 
(defun C:test ( / dcl_id dclcontent dclname userclick temp) 
  (vl-load-com) 
  (setq temp (getvar "cmdecho")) 
  (setvar "cmdecho" 0) 
  (command "undo" "be") 
  (setq dclcontent (list 
           "qjchenedynamicltscale:dialog{" 
           "label=\"dynamic linetype scale modify by qjchen\";" 
           ":button{" 
                "key = \"button1\";" 
                "label = \"individual object ltscale\";}" 
           ":button{" 
                "key = \"button2\";" 
                "label = \"overall ltscale\";}" 
           "ok_cancel;}") 
  dclname "qjchendltscale" 
  ) 
  (setq dcl_id (load_dialog (qjchencreatdcl dclname dclcontent))) 
  (if (not (new_dialog "qjchenedynamicltscale" dcl_id)) (exit)) 
  (action_tile "button1" "(done_dialog 3)") 
  (action_tile "button2" "(done_dialog 4)") 
  (setq userclick (start_dialog)) 
  (unload_dialog dcl_id) 
  (cond ((= 3 userclick)(qjchenedltscale 1)) 
        ((= 4 userclick)(qjchenedltscale 2)) 
  ) 
  (command "undo" "e") 
  (setvar "cmdecho" temp) 
) 
 
(defun qjchenedltscale(n / a b gr linetype newscale o orilst overallltscale zq) 
  (prompt "\n Please select one not continuous linetype object:") 
  (setq a (car (entsel)) o (vlax-ename->vla-object a)) 
  (setq orilst (vlax-get-property o 'LinetypeScale)) 
  (setq linetype (cdr (assoc 6 (entget a)))) 
  (if (= linetype nil) 
      (setq linetype (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 (entget a))))))) 
  ) 
  (if (and linetype (/= linetype "Continuous")) 
    (progn 
      (setq zq (cdr (assoc 40 (tblsearch "ltype" linetype)))) 
      (setq overallltscale (getvar "LTSCALE")) 
      (setq b (getpoint "\nSelect one point:")) 
      (while (= (car (setq gr (grread nil 5 0))) 5) 
        (redraw) 
        (grdraw (cadr gr) b 1 1) 
        (setq newscale (/ (distance (cadr gr) b) zq overallltscale)) 
        (apply-props o (list (list "LinetypeScale" newscale))) 
      ) 
      (if (= n 2) 
        (progn 
          (setvar "ltscale" (* overallltscale (/ newscale orilst))) 
          (apply-props o (list (list "LinetypeScale" orilst))) 
          (command "regen") 
        ) 
      ) 
    ) 
  ) 
  (vlax-release-object o) 
  (princ) 
) 
 
;;from dave theswamp 
(defun apply-props (object proplist) 
  (foreach prop proplist 
    (if (vlax-property-available-p object (car prop)) 
      (vlax-put-property object (car prop) (cadr prop)) 
    ) 
  ) 
) 
 
(defun qjchencreatdcl(dclname lst) 
 (setq dcl_name (strcat (getenv "temp") "\\" dclname ".dcl") 
        f (OPEN dcl_name "w") 
  ) 
  (foreach x lst 
     (write-line x f) 
   ) 
  (close f) 
  dcl_name 
) 
 
;;end main program 
(princ "\n By <a href=\"mailto:qjchen@gmail.com\">qjchen@gmail.com</a>, dynamic linescale, The command is test") 
(princ)

Michael527 · 发表于 2021-1-19 15:16:38

这个工具不错，谢谢楼主的分享！

bzhjl · 发表于 2021-1-19 15:39:50

很直观，谢谢分享！

dmxcs · 发表于 2021-1-20 11:23:14

谢谢楼主的分享！

zero423 · 发表于 2021-1-21 10:50:14

跟大神学习学习!

yudore · 发表于 2021-1-26 11:23:45

大佬插件效果很好，就是不知道命令是怎么调出来的？是“test”么，怎么调不出来gif上对话框呢？求帮助

账号		自动登录	找回密码
密码			立即注册

[每日一码] 动态修改线型比例

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。