find each boundary of the select object

 

;;; ========================================================================
;;; Some of the following code are writen by QJCHEN                         
;;; Civil engineering Department, South China University of Technology      
;;; Purpose: To Find each closed boundary in the selection                  
;;; Version: 0.1                                                            
;;; Limitation: Can't generate the boundary by spline                       
;;; 2006.06.01                                                              
;;; Thanks to the code from Korea friend from http://xoutside.com/          
;;; whose code find the intersections of two points and many object         
;;; And thanks to the initial code from Mr.Tony Hotchkiss at Cadalyst       
;;; Original post :www.Theswamp.org                                         
;;; ========================================================================

(defun c:bb (/ clayer a b dis ay by th th0 lp rp inter1 inter1mid inter2
                 inter2mid i len plboundary 
              )
  (command "_undo" "_be")
  (startTimer)
  (setting)
  (setq clayer (getvar "clayer"))
  (command "_layer" "n" "bound" "s" "bound" "c" 3 "" "")
  (setq a (getpoint "\n the left up point"))
  (setq b (getcorner a "\n the bottom right point"))
  (setq dis (getdist "\n the minimum distance"))
  (setq ay (nth 1 a)
        by (nth 1 b)
  )
  (setq th by)
  (setq th0 dis)
  (while (< th ay)
    (setq lp (list (nth 0 a) th 0))
    (setq rp (list (nth 0 b) th 0))
    (grdraw lp rp 249)
    (setq inter1 (vl-Get-Int-Pt lp rp "bound" 0))
    (setq inter1mid (midlist inter1))
    (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)
          inter2mid (midlista inter2)
    )
    (command "_layer" "s" "bound" "")
    (setq i 0
          len (length inter1)
    )
    (repeat (1- len)
      (setq midpoint (nth i inter1mid))	
      (if (not (member1 midpoint inter2mid))
        (progn
          (setq plboundary (STD-BPOLY midpoint nil))
          (if plboundary
            (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)
                  inter2mid (midlista inter2)
            )
          )
          )
      )
      (setq i (1+ i))
    )
    (command "_layer" "s" clayer "")
    (setq th (+ th th0))
  )
  (resetting)
  (endTimer (vl-symbol-name 'c:bb))
  (command "_undo" "_e")
)

;
(defun member1 (a b / res)
  (if b
    (foreach x b
      (if (< (distance x a) 0.01)
        (progn
          (setq res T)
        )			       ; (setq res nil)
      )
    )				       ; (setq res nil)
  )
  res
)
(defun midlist (lst / len lst1 midpoint i)
  (setq i 0
        len (length lst)
  )
  (repeat (1- len)
    (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))
    (setq lst1 (append
                 lst1
                 (list midpoint)
               )
    )
    (setq i (1+ i))
  )
  lst1
)
(defun midlista (lst / len lst1 midpoint i)
  (setq i 0
        len (length lst)
  )
  (repeat (/ len 2)
    (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))
    (setq lst1 (append
                 lst1
                 (list midpoint)
               )
    )
    (setq i (+ i 2))
  )
  lst1
)

;;; -----------------------------------------------------------------
;;; | The following code taken xarch.tu-graz.ac.at/autocad/stdlib/  |
;;; | Thanks to the great code "STDLIB" that wrote by MR.Reini Urban|
;;; -----------------------------------------------------------------

(defun STD-BPOLY (pt ss / ele)
  (cond
    ((member (type C:BPOLY) '(SUBR EXRXSUBR EXSUBR))
      (if ss
        (C:BPOLY pt ss)		       ; old arx or ads function
        (C:BPOLY pt)
      )
    )
    (pt				       ; >=r14: native command
        (setvar "CMDDIA" 0)
        (setq ele (entlast))	       ; (std-break-command)
        (command "_BPOLY" "_A" "_I" "_N" "") ; advanced options
				       ; without island detection
        (if ss
          (command "_B" "_N" ss "")
        )			       ; define boundary set if ss
        (command "" pt "") (setvar "CMDDIA" 1)
        (if (/= (entlast) ele)
          (entlast)
        )
    )				       ; return created BPOLY
    (T
      (alert "command _BPOLY not available")
    )
  )
)


;;; -------------------------------------------------------------------
;;; | The following code are taken from xoutside.com                  |
;;; | http://xoutside.com/CAD/lisp/lisp_chair.htm                     |
;;; | Thanks to the Korea friend                                      |
;;; | Purpose: Get the intersection of Two object                     |
;;; -------------------------------------------------------------------

(defun vl-Get-Int-Pt (FirstPoint SecondPoint lay layindex / acadDocument
                                 mSpace SSetName SSets SSet reapp ex obj
                                 Baseline
                     )
  (vl-load-com)
  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq mSpace (vla-get-ModelSpace acadDocument))
  (setq SSetName "MySSet")
  (setq SSets (vla-get-SelectionSets acadDocument))
  (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets
                                                               SSetName
                                                         )
                            )
      )
    (vla-clear (vla-Item SSets SSetName))
  )
  (setq SSet (vla-Item SSets SSetName))
  (setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)
                              (vlax-3d-point SecondPoint)
                 )
  )
  (vla-SelectByPolygon SSet acSelectionSetFence
                       (kht:list->safearray (append
                                              FirstPoint
                                              SecondPoint
                                            ) 'vlax-vbdouble
                       )
  )
  (vlax-for obj sset (if (setq ex (kht-intersect
                                                 (vlax-vla-object->ename BaseLine)
                                                 (vlax-vla-object->ename obj)
                                                 lay layindex
                                  )
                         )
                       (setq reapp (append
                                     reapp
                                     ex
                                   )
                       )
                     )
  )
  (vla-delete BaseLine)
  (setq reapp (vl-sort reapp '(lambda (e1 e2)
                                (< (car e1) (car e2))
                              )
              )
  )
  reapp
)


;;; Original post:http://xoutside.com/CAD/lisp/lisp_chair.htm 
;;; Modify little by QJCHEN to filter TEXT SPLINE and layer   
(defun kht-intersect (en1 en2 lay layindex / a b x ex ex-app c d e la2)
  (vl-load-com)
  (setq c (cdr (assoc 0 (entget en1)))
        d (cdr (assoc 0 (entget en2)))
        la2 (cdr (assoc 8 (entget en2)))
  )
  (if (or
        (= c "TEXT")
        (= d "TEXT")
        (= c "SPLINE")
        (= d "SPLINE")
      )
    (setq e -1)
  )
  (if (= layindex 0)
    (if (= la2 lay)
      (setq e -1)
    )
  )
  (if (= layindex 1)
    (if (/= la2 lay)
      (setq e -1)
    )
  )
  (setq En1 (vlax-ename->vla-object En1))
  (setq En2 (vlax-ename->vla-object En2))
  (setq a (vla-intersectwith en1 en2 acExtendNone))
  (setq a (vlax-variant-value a))
  (setq b (vlax-safearray-get-u-bound a 1))
  (if (= e -1)
    (setq b e)
  )
  (if (/= b -1)
    (progn
      (exapp a)
    )
    nil
  )
)

(defun exapp (a)
  (setq a (vlax-safearray->list a))
  (repeat (/ (length a) 3)
    (setq ex-app (append
                   ex-app
                   (list (list (car a) (cadr a) (caddr a)))
                 )
    )
    (setq a (cdr (cdr (cdr a))))
  )
  ex-app
)

(defun kht:list->safearray (lst datatype)
  (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0
                                                                  (1-
                                                                      (length lst)
                                                                  )
                                                            )
                       ) lst
  )
)

;;; ----------------------------------------------------------
;;; |           midpoint function                            |
;;; ----------------------------------------------------------
(defun midp (p1 p2)
  (mapcar
    '(lambda (x)
       (/ x 2.)
     )
    (mapcar
      '+
      p1
      p2
    )
  )
)


;;; -----------------------------------------------------------------
;;; | The following code taken from Mr.Tony Hotchkiss at Cadalyst   |
;;; | To set and reset the system variable                          |
;;; -----------------------------------------------------------------

(defun err (s)
  (if (= s "Function cancelled")
    (princ "\nALIGNIT - cancelled: ")
    (progn
      (princ "\nALIGNIT - Error: ")
      (princ s)
      (terpri)
    )				       ; _ end of progn
  )	 			       ; _ end of if
  (resetting)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
  (setq x (read (strcat systvar "1")))
  (set x (getvar systvar))
  (setvar systvar newval)
)
;;; setv
(defun setting ()
  (setq oerr *error*)
  (setq *error* err)
  (setv "BLIPMODE" 0)
  (setv "CMDECHO" 0)
  (setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
  (setq x (read (strcat systvar "1")))
  (setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
  (rsetv "BLIPMODE")
  (rsetv "CMDECHO")
  (rsetv "OSMODE")
  (setq *error* oerr)
)


;;; -----------------------------------------------------------------
;;; | The following code taken from www.theswamp.org                |
;;; | To calculate the time that the program run                    |
;;; -----------------------------------------------------------------

(defun startTimer ()
  (setq time (getvar "DATE"))
)
(defun endTimer (func)
  (setq time (- (getvar "DATE") time)
        seconds (* 86400.0 (- time (fix time)))
  )
  (gc)
  (outPut seconds func)
)
(defun outPut (secs def)
  (princ "\nPurging...")
  (command "PURGE" "Layers" "*" "N")
  (gc)
  (princ (strcat "\nTimed " def ": " (rtos secs 2 6)))
  (princ)
)

(princ "\n Please use the bb command to run")