;|
closed boundary in the selection
|;
(defun
my_error (msg)
(setvar
"cmdecho" old_cmdecho)
(if
(or
(= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ)
(princ (strcat "\nError: " msg))
)
(if
msg (Alert (strcat "\nApplication error: " msg)))
(setvar "cmdecho" old_cmdecho)
(setvar "osmode" old_osnap)
(setvar "snapmode" old_snap)
(setvar "orthomode" old_ortho)
(setvar "dimdec" old_dimdec)
(setq *error* old_error)
(princ)
);;end
my_error
(defun
c:cbs (/ clayer pa pb dis ay by th th0 lp rp inter1 inter1mid inter2 inter2mid
i len plboundary)
(setq
old_cmdecho(getvar "cmdecho"))
(setq
old_osnap (getvar "osmode"))
(setq
old_layer (getvar "clayer")) ;
layer
(setq
old_error *error*)
(setq
*error* my_error )
(setvar
"cmdecho" 0)
(setvar
"osmode" 0)
(command "_undo"
"_be")
(setq old_layer (getvar
"clayer"))
(if
(not (tblsearch "LAYER" "mybound"))
(command "._layer"
"_M" "mybound" "_Color" "3"
"" "LType" "Continuous" ""
"")
)
(setq pa (getpoint "\n Pick the left
up point"))
(setq pb (getcorner pa "\n Pick the
bottom right point"))
(setq dis (getdist "\n Enter minimum
distance"))
(setq ay (nth 1 pa)
by (nth 1 pb)
)
(setq th by)
(setq th0 dis)
(while
(< th ay)
(setq lp (list (nth 0 pa) th 0))
(setq rp (list (nth 0 pb) th 0))
(grdraw lp rp 249)
(setq inter1 (vl-Get-Int-Pt lp rp
"mybound" 0))
(setq inter1mid (midlist inter1))
(setq inter2 (vl-Get-Int-Pt lp rp
"mybound" 1)
inter2mid (midlista inter2)
)
(setvar "clayer"
"mybound")
(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))
)
(setvar "clayer" old_layer)
(setq th (+ th th0))
)
(command "_undo" "_e"
"_redraw"
)
(setvar
"cmdecho" old_cmdecho)
(setvar
"osmode" old_osnap)
(setvar
"clayer" old_layer)
(setq
*error* old_error)
(princ)
)
;;------------------------------------
(prompt
"\n Enter CBS to Start closed boundary in the selection.")
;;------------------------------------
(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
)
;;------------------------------------
(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")
)
)
)
;;------------------------------------
(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
)
;;------------------------------------
(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
)
)
)
