;;局部放大
(defun c:fs_jbfd (/	*error*	    box	  cen	dist  dpt   en	  label
		  le	len   lst   mpt	  nen	nss   oss   pt	  sc
		  ss	sz    tsz   leader	ltext
		 )
  (setq oss (cadr (ssgetfirst)))
  (setvar "cmdecho" 0)
  (defun *error* (msg) (command ".undo" "e" "u") (princ))
  (command ".undo" "be")
  (if (and oss (= (sslength oss) 1))
    (setq en (ssname oss 0))
    (progn (setvar "cmdecho" 1)
	   (princ "\n指定放大中心点：")
	   (command ".circle")
	   (while (/= 0 (getvar "cmdactive")) (command "\\"))
	   (setq en (entlast))
    )
  )
  (princ "\n指定视图名称或位置：")
  (setq label (chr (fsxm_drw_leader en)))
  (setq leader (entnext en))
  (setq ltext (entnext leader))
  (or $fsxm_jbfdsc$ (setq $fsxm_jbfdsc$ 2))
  (setq	sc (getdist
	     (strcat "输入放大比例<"
		     (fsxm-tostring $fsxm_jbfdsc$)
		     ">："
	     )
	   )
  )
  (if sc
    (setq $fsxm_jbfdsc$ sc)
    (setq sc $fsxm_jbfdsc$)
  )
  (setvar "cmdecho" 0)
  (command ".ucs" "w")
  ;;
  (setq le (entlast))
  (setq len (fsxm-curve-length en))
  (setq dist 0)
  (setq sz (fsxm-pickboxsize))
  (repeat (1+ (fix (/ len sz)))
    (setq dpt (vlax-curve-getPointAtDist en dist))
    (setq dist (+ sz dist))
    (setq lst (cons dpt lst))
  )
  (setq ss '((-4 . "<NOT") (0 . "DIMENSION") (-4 . "NOT>")))
  (setq ss (ssget "CP" lst ss))
  (ssdel en ss)
  (ssdel leader ss)
  (ssdel ltext ss)
  (command ".copy" ss "" "@" "@")
  (command ".copy" en "" "@" "@")
  (setq nen (entlast))
  (setq nss (fsxm-newselection le))
  (setq box (fsxm-obj-box (vlax-ename->vla-object en)))
  (setq cen (apply 'fsxm-midpt box))
  (setq pt (mapcar '- (car box) (list sz sz sz)))
  (fsxm_fence_trim nen pt nss)
  (setq nss (fsxm-newselection le))
  (command ".scale" nss "" "non" cen sc)
  (command ".ucs" "p")
  (setq box (fsxm-obj-box (vlax-ename->vla-object nen)))
  (setq tsz (getvar "textsize"))
  (setq mpt (* 0.5 (- (caadr box) (caar box))))
  (setq mpt (mapcar '+ (car box) (list mpt (* -3 tsz) 0)))
  (entmake
    (list
      '(0 . "MTEXT")
      '(100 . "AcDbEntity")
      '(100 . "AcDbMText")
      (cons 10 mpt)
      '(41 . 0.0)
      '(71 . 5)
      '(72 . 5)
      (cons 1
	    (strcat "{\\S" label "/" (fsxm-tostring sc) ":1;}")
      )
      (cons 7 (getvar "textstyle"))
      '(50 . 0.0)
      '(73 . 1)
      '(44 . 1.0)
    )
  )
  (princ "\n指定放置点：")
  (command "move" nss (entlast) "" "non" (trans cen 0 1) "\\")
  ;;做组1
  (setq ss (fsxm-enlist->ss (list nen (entlast)) nil))
  (fsxm-add-group ss "*")
  ;;做组2
  (setq ss (list en (entnext en) (entnext (entnext en))))
  (setq ss (fsxm-enlist->ss ss nil))
  (fsxm-add-group ss "*")
  ;;
  (command ".undo" "e")
  (princ)
)
;;动态拖动做一个箭头
(defun fsxm_drw_leader (en / drag settxt el en led obj txt)
  (setq el (entlast))
  (if $fsxm_jbfd$
    (setq $fsxm_jbfd$ (1+ $fsxm_jbfd$))
    (setq $fsxm_jbfd$ 65)
  )
  (if (or (< $fsxm_jbfd$ 65) (> $fsxm_jbfd$ 90))
    (setq $fsxm_jbfd$ 65)
  )
  (command ".leader" "0,0" "10,10" "" (chr $fsxm_jbfd$) "")
  (setq led (entnext el))
  (setq obj (vlax-ename->vla-object led))
  (setq txt (entnext led))
  (defun drag (pt / lpt)
    (setq pt (trans pt 1 0))
    (setq lpt (vlax-curve-getClosestPointTo en pt))
    (vla-put-Coordinate obj 0 (vlax-3d-point lpt))
    (fsxm-setendxf txt 10 pt)
    (vla-put-Coordinate obj 1 (vlax-3d-point pt))
    (vla-Evaluate obj)
  )
  (defun settxt	(key)
    (setq $fsxm_jbfd$ (Ascii (strcase key)))
    (fsxm-setendxf txt 1 (strcase key))
  )
  (fsxm-drag '(setq mousemove '(drag dypoint)
		   keydown   '(settxt key)
		   Curtype   1
	     )
  )
  $fsxm_jbfd$
)
;;快速修剪
(defun c:fs_etr	(/ en pt)
  (if (and (setq en (car (entsel "\n选择修剪边界：")))
	   (progn (redraw en 3)
		  (setq pt (getpoint "\n选择剪切方向："))
	   )
	   (setq pt (trans pt 1 0))
      )
    (fsxm_fence_trim en pt nil)
  )
  (princ)
)
;;快速修剪子程序
(defun fsxm_fence_trim (en    pt    trss  /	ang   cpt   dist  dpa
			dpt   dss   len	  pi2	ss    sz    trpt  v
			smod  new   isleft	ssgetc	    trimen
		       )
  (defun isleft	(en pt / ang ang0 pa prj)
    (setq prj (vlax-curve-getclosestpointto en pt))
    (cond ((equal prj pt 1e-6) 0)
	  (t
	   (setq ang (angle prj pt))
	   (setq pa (vlax-curve-getParamAtPoint en prj))
	   (setq ang0 (angle '(0 0) (vlax-curve-getFirstDeriv en pa)))
	   (if (if (< ang0 pi)
		 (and (> ang ang0) (< ang (+ ang0 pi)))
		 (or (> ang ang0) (< ang (- ang0 pi)))
	       )
	     1
	     -1
	   )
	  )
    )
  )
  (defun ssgetc	(wpt sz)
    (ssget "C"
	   (mapcar '+ (trans wpt 0 1) (list sz sz))
	   (mapcar '- (trans wpt 0 1) (list sz sz))
	   '((0 . "*line,arc,circle,ellipse,hatch,ray"))
    )
  )
  (defun trimen	(e trpt / el ne)
    (setq el (entlast))
    (command (list e (trans trpt 0 1)))
    (if	(/= el (setq ne (entlast)))
      (entupd ne)
    )
  )
  (setvar "cmdecho" 0)
  (setq smod (getvar "pickstyle"))
  (setvar "pickstyle" 0)
  (sssetfirst nil)
  (command ".trim" en "")
  (setq sz (* 0.5 (fsxm-pickboxsize)))
  (if (listp pt)
    (setq v (isleft en pt))
    (setq v pt)
  )
  (setq pi2 (* v (/ pi 2)))
  (setq len (fsxm-curve-length en))
  (setq dist 0)
  (repeat (1+ (fix (/ len sz)))
    (setq dpt (vlax-curve-getPointAtDist en dist))
    (setq dpa (vlax-curve-getParamAtDist en dist))
    (setq dist (+ sz dist))
    (setq ang (angle '(0 0) (vlax-curve-getFirstDeriv en dpa)))
    (setq trpt (polar dpt (+ ang pi2) sz))
    (if	(and (= v (isleft en trpt))
	     (setq dss (ssgetc trpt sz))
	     (setq dss (ssdel en dss))
	     (setq dss (fsxm-ss->enlist dss))
	)
      (foreach e dss
	(setq cpt (vl-catch-all-apply
		    'vlax-curve-getclosestpointto
		    (list e trpt)
		  )
	)
	(if (or	(vl-catch-all-error-p cpt) ;剖面线?
		(= v (isleft en cpt))
	    )
	  (if trss
	    (if	(ssmemb e trss)		;只剪指定对像
	      (if (setq new (trimen e trpt))
		(ssadd new trss)
	      )
	    )
	    (trimen e trpt)
	  )
	)
      )
    )
  )
  (command "")
  (setvar "pickstyle" smod)
  (redraw en 4)
)
(princ
  "\n*****单侧快速修剪：fs_etr，局部放大：fs_jbfd 飞诗寻梦2009-5-21*****\n"
)
(princ)