;|
(vl-load-com)
(setq *acad* (vlax-get-acad-object))
(setq *doc* (vla-get-ActiveDocument *acad*))
;;选择集转化为表
(defun fsxm-ss->enlist (ss / lst n en)
  (setq n -1)
  (while (setq en (ssname ss (setq n (1+ n))))
    (setq lst (cons en lst))
  )
)
;;pickbox大小
(defun fsxm-pickboxsize	()
  (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
     (getvar "viewsize")
  )
)
;;画一个标志点
(defun fsxm-pt-grdraw (upt col / pts sz)
  (setq sz (fsxm-pickboxsize))
  (setq	pts (fsxm-9ptbox
	      (mapcar '- upt (list sz sz))
	      (mapcar '+ upt (list sz sz))
	    )
  )
  (grdraw (fsxm-nths '(0 0) pts) (fsxm-nths '(2 2) pts) col)
  (grdraw (fsxm-nths '(2 0) pts) (fsxm-nths '(0 2) pts) col)
  (grdraw (fsxm-nths '(1 0) pts) (fsxm-nths '(1 2) pts) col)
  (grdraw (fsxm-nths '(2 1) pts) (fsxm-nths '(0 1) pts) col)
)
;;以索引 [查找] 表中元素
(defun Fsxm-Nths (item lst)
  (or (listp item) (setq item (list item)))
  (foreach index item
    (setq lst (nth index lst))
  )
)
;;2点变9点
(defun fsxm-9ptbox (p1 p2 / x x1 x2 y y1 y2)
  (setq x1 (car p1))
  (setq y1 (cadr p1))
  (setq x2 (car p2))
  (setq y2 (cadr p2))
  (setq x (* 0.5 (+ x2 x1)))
  (setq y (* 0.5 (+ y2 y1)))
  (mapcar (function
	    (lambda (a) (mapcar 'list (list x1 x x2) (list a a a)))
	  )
	  (list y1 y y2)
  )
)
;;线长
(defun Fsxm-curve-length (cv)
  (vlax-curve-getDistAtParam cv (vlax-curve-getEndParam cv))
)
;;无声退出
(defun fsxm-silenceexit	(/ *error*)
  (t (setq *error* strcat))
)
;;联网验证试用
(vl-catch-all-apply
  (function
    (lambda (/ dom xml var)
      (SetQ dom (vla-GetInterfaceObject *acad* "Microsoft.XMLHTTP"))
      (vla-open	dom
		"GET"
		"http://fsxm.mjtd.com/soft/other/chkpkt.xml"
		0
      )
      (vl-catch-all-apply 'vlax-invoke-method (list dom 'Send))
      (setq xml (vlax-get-property dom 'responseXML))
      (setq *OK* (vlax-get xml 'lastchild))
    )
  )
)
|;
;;主程序
(defun c:chkpkt	(/ a ep f olst sp ss notopen getptss dist i sz css)
  ;|(or *OK*
      (progn
	(alert "本程序试用期已过!\n请联系飞诗: fsxm.acad@qq.com")
	(fsxm-silenceexit)
      )
  )|;
  (defun notopen (pt en / ss tmp en2)
    (if	(setq ss (ssget "C" pt pt f))
      (ssdel en ss)
    )    
    (and ss
	 (setq en2 (ssname ss 0))
	 (vlax-curve-getParamAtPoint en2 pt)
    )
  )
  (defun getptss (en pt	maxdist	/ ang cl dist dist_s en_s n plst prj ss
		  step i OL)
    (setq cl (* 2 pi maxdist))
    (setq n (fix (max 8 (/ cl sz))))
    (setq step (/ pi (min n 64) 0.5))	;步进角度
    (setq ang (* 2 pi))
    (while (> ang 0)
      (setq ang (- ang step))		;步进角度
      (setq plst (cons (polar pt ang maxdist) plst))
    )
    ;;(mapcar 'mpt plst)
    (setq ss (ssget "CP" plst f))
    (setq i 0)
    (if	(and ss (> (sslength ss) 1))
      (progn
	(setq ol (fsxm-curve-length en))
	(command ".extend" ss "" (list en pt)) ;伸长
	(if (> (- (fsxm-curve-length en) ol)
	       maxdist
	    )				;伸的太长了
	  (command "u")
	)
	(command "")

	(cond ((equal (fsxm-curve-length en) ol 1e-10) ;没有伸长
	       (command ".trim" ss "" (list en pt)) ;修剪模式
	       (if (> (- ol (fsxm-curve-length en)) maxdist)
		 (command "u")		;剪的太多了
	       )
	       (command "")
	      )
	)
					;计数
	(if (equal (fsxm-curve-length en) ol 1e-10)
	  (fsxm-pt-grdraw pt 1)
	  (progn
	    (setq i (1+ i))
	    (fsxm-pt-grdraw pt 3)
	  )
	)
      )
    )
    i
  )
  (setq	f '((0 . "*line,arc,circle,ellipse")
	    (-4 . "<NOT")
	    (0 . "XLINE,MLINE")
	    (-4 . "NOT>")
	   )
  )
  (or (setq ss (ssget f)) (fsxm-silenceexit))
  (foreach en (fsxm-ss->enlist ss)
    (setq sp (trans (vlax-curve-getStartPoint en) 0 1))
    (setq ep (trans (vlax-curve-getEndPoint en) 0 1))
    (cond ((not (equal sp ep 1e-8))
	   (or (notopen sp en) (setq olst (cons (list en sp) olst)))
	   (or (notopen ep en) (setq olst (cons (list en ep) olst)))
	  )
    )
  )
  (if (= 0 maxdist)
    (alert
      "\n请尽量精确输入一个小的搜索半径\n过大的搜索半径会导致\n程序执行速度及准确性下降!"
    )
  )
  (setq
    dist (getdist (strcat "\n输入边界搜索半径<" (rtos maxdist) ">:"))
  )
  (if dist
    (setq maxdist dist)
    (setq dist maxdist)
  )
  (setq i 0)
  (vla-StartUndoMark *doc*)
  (setvar "edgemode" 1)
  (setvar "cmdecho" 0)
  (setq sz (fsxm-pickboxsize))
  (setq css (ssadd))
  (foreach a olst
    (setq i (+ i (apply 'getptss (append a (list dist)))))
  )
  (vla-EndUndoMark *doc*)
  (sssetfirst nil css)
  (setq olst (itoa (length olst)))
  (princ
    (strcat "\n　●本次共修复开口点<" (itoa i) ">个.....")
  )
  (princ)
)
(defun c:ck () (c:chkpkt))
(princ
  "\n*****飞诗CAD[fsxm.mjtd.com] - 修复开口 命令:chkpkt/ck *****"
)
(setq maxdist 0)
