;动态箭头线型
(defun c:qgjt( / old_cmd ss pt sf )

(defun sf ( pt ss / alts gr s1 newscale)
   (setq alts (getvar "LTSCALE")
         zq (mai_dxf 40 (tblsearch "ltype" (mai_dxf 6 (car ss))))
         ss (mapcar 'vlax-ename->vla-object ss)
   )
   (while (= (car (setq gr (grread nil 5 0))) 5)
      (redraw)
      (grdraw (cadr gr) pt 1 1)
      (setq newscale (if (mai_equal zq 0) 1 (/ (distance (cadr gr) pt) zq alts)))
      (foreach s1 ss (vlax-put s1 'LinetypeScale newscale))
   )
   (redraw)
   (princ)
)

   (mini_start nil)
   (setq ss (mai_select_first '((0 . "*POLYLINE,ELLIPSE,SPLINE,LINE,CIRCLE,ARC")) "选择要修改线形的线:<退出>" "没有选择线."))
   (or (tblsearch "ltype" "arrowline")
       (mai_load_templin
           "ARROWLINE"
           (list "*ARROWLINE,箭头线 LTscale=箭头大小\nA,4,[ZIG,ltypeshp.shx,y=1,r=270,s=1],4")
       )
   )
   (command "_.chprop" ss "" "lt" "ARROWLINE" "")
   (setq ss (mai_ssget_2_list ss))
   (foreach pt ss
        (if (wcmatch (mai_dxf 0 pt) "*POLYLINE")
            (command "_.pedit" pt "l" "on" "")
        )
   )
   (or (setq pt (getpoint "\n动态调整箭头比例:<不调整>"))
       (exit)
   )
   (sf pt ss)
   (mai_end)
)



;;; 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
