(defun c:CONNECTBLKS ( / *error* dynp dynm opt ans osm blk s_pt ss cnt pt_lst e_lst ent p_ent s_param e_param)
(defun *error* ( msg )
(if dynp (setvar 'dynprompt dynp))
(if dynm (setvar 'dynmode dynm))
(if osm (setvar 'osmode osm))
(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occured.")))
(princ)
);_end_*error*_defun
(cond ( (/= (getvar 'dynprompt) 1) (setq dynp (getvar 'dynprompt)) (setvar 'dynprompt 1)))
(cond ( (/= (getvar 'dynmode) 3) (setq dynm (getvar 'dynmode)) (setvar 'dynmode 3)))
(initget "Closed Open")
(setq opt "Closed"
ans (getkword (strcat "\nProduce a [Closed/Open] Polyline < " opt " > : "))
);end_setq
(if ans (setq opt ans))
(cond ( (eq opt "Open")
(if (/= (getvar 'osmode) 0) (setq osm (getvar 'osmode)))
(setvar 'osmode 0)
(setq blk "")
(while (/= blk "INSERT")
(setq s_pt (cdr (assoc 10 (entget (setq ent (car (entsel "\nSelect Start Block : "))))))
blk (cdr (assoc 0 (entget ent)))
);end_setq
);end_while
(setvar 'osmode osm)
)
);end_cond
(setq ans 0)
(while (< ans 2)
(if (= opt "Open") (prompt "\nSelect Additional Blocks to Connect : ") (prompt "\nSelect All Blocks to Connect : "))
(setq ss (ssget '((0 . "INSERT"))))
(if (and (= opt "Open") (not (ssmemb ent ss))) (setq ss (ssadd ent ss)))
(setq ans (sslength ss))
(cond ( (< ans 2) (alert (strcat "Selection Set must contain\n2 DIFFERENT BLOCKS to Connect.\nCurrent Size : " (itoa ans))) (setq ss nil)))
);end While
(cond ( (>= (sslength ss) 2)
(setq cnt (1- (sslength ss)))
(repeat (sslength ss)
(setq pt_lst (cons (cdr (assoc 10 (entget (ssname ss cnt)))) pt_lst)
cnt (1- cnt)
);end_setq
);end_repeat
(if (= (sslength ss) 2) (setq cpl 0) (setq cpl 1))
(setq e_lst (LM:ConvexHull pt_lst)
ent (entmakex
(append
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length e_lst))
'(62 . 1)
(cons 70 cpl)
);end_list
(mapcar '(lambda ( x ) (cons 10 x)) e_lst)
);end_append
);end_entmakex
);end_setq
(if (> (length pt_lst) (length e_lst)) (setq p_ent (ee:spl pt_lst e_lst ent)) (setq p_ent ent))
(cond ( (= opt "Open")
(setq s_param (vlax-curve-getparamatpoint p_ent s_pt))
(cond ( (= s_param 0.0)
(vlax-put-property (vlax-ename->vla-object p_ent) 'closed :vlax-false)
);end_sub_cond_start point is start of polyline
(
(setq e_param (1- s_param))
(vl-cmdf "_break" p_ent "_F" s_pt (vlax-curve-getpointatparam p_ent e_param))
);end_cond_otherwise
);end_cond
);end_sub_cond_open polyline required
);end_cond
(bk:rightagleing p_ent) ;; added by BeekeeCZ 22-12-12
);end_selection_set
);end_cond
(if dynp (setvar 'dynprompt dynp))
(if dynm (setvar 'dynmode dynm))
(princ)
);end_defun
;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond ( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< c d)
)
)
)
)
)
(setq ch (list (caddr lst) (cadr lst) (car lst)))
(foreach pt (cdddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
(setq ch (cons pt (cddr ch)))
)
)
ch
)
)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
;; Evgeniy Elpanov's code for shortest polyline
;; adapted for use with Lee Mac's Convex Hull
;; by Ron Harman (dlanorh)
(defun ee:spl (p_lst ll ent / D D0 D1 E EP LS P)
(defun f1 (a ent / p)
(setq p (vlax-curve-getpointatparam ent (fix (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent a))))
p (list 10 (car p) (cadr p))
);end_setq
(entmod (append (reverse (member p (reverse (entget ent)))) (list (cons 10 a)) (cdr (member p (entget ent)))))
);end_defun
(setq p_lst (mapcar (function cddr)
(vl-sort
(mapcar (function (lambda (a / b) (cons (distance a (setq b (vlax-curve-getclosestpointto ent a))) (cons (vlax-curve-getparamatpoint ent b) a)))) p_lst)
(function (lambda (a b) (if (equal (car a) (car b) 1) (<= (cadr a) (cadr b)) (< (car a) (car b)))))
);end_vl-sort
);end_mapcar
ls p_lst
);end_setq
(foreach a ll (setq ls (vl-remove a ls)))
(foreach a ls
(setq p (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent a))
p (if (zerop (rem p 1.))
(if (zerop p)
(vlax-curve-getendparam ent)
(1- p)
);end_if
(fix p)
);end_if
p (vlax-curve-getpointatparam ent p)
p (list 10 (car p) (cadr p))
);end_setq
(entmod (append (reverse (member p (reverse (entget ent)))) (list (cons 10 a)) (cdr (member p (entget ent)))))
);end_foreach
(foreach a p_lst (setq ll (vl-remove a ll)))
(entmod (vl-remove-if (function (lambda (a) (member (cdr a) ll))) (entget ent)))
(setq p_lst (mapcar (function cdr) (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget ent)))
p_lst (mapcar (function list) (cons (last p_lst) p_lst) p_lst)
ep (length p_lst)
d0 (vlax-curve-getdistatparam ent ep)
);end_setq
(while (> d0 (progn
(foreach a p_lst
(setq e (entget ent)
d (vlax-curve-getdistatparam ent ep)
);end_setq
(entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))
(f1 (car a) ent)
(f1 (cadr a) ent)
(if (<= d (setq d1 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))))
(entmod e)
(setq d d1
e (entget ent)
);end_setq
);end_if
(entmod (vl-remove (cons 10 (car a)) (vl-remove (cons 10 (cadr a)) e)))
(f1 (cadr a) ent)
(f1 (car a) ent)
(if (<= d (setq d1 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))))
(entmod e)
(setq d d1
e (entget ent)
);end_setq
);end_if
);end_foreach
d
);end_progn
);end_"<"
(setq d0 d)
);end_while
(setq rtn (cdr (assoc -1 e)))
);end_defun
(defun bk:rightagleing (e / d db dv dv+)
(setq d (entget e)
c (= 1 (logand (cdr (assoc 70 d)) 1))
db (vl-remove-if '(lambda (x) (vl-position (car x) '(10 40 41 42 91 90))) d)
dv (vl-remove-if '(lambda (x) (/= (car x) 10)) d)
dv+ (mapcar '(lambda (v1 v2) (if (and (not (equal (cadr v1) (cadr v2) 1e-9))
(not (equal (caddr v1) (caddr v2) 1e-9)))
(list v1 (list 10 (cadr v1) (caddr v2)))
(list v1)))
dv (if c (append (cdr dv) (list (car dv))) (cdr dv)))
dv+ (apply 'append dv+))
(if (not c) (setq dv+ (append dv+ (list (last dv)))))
(entmod (append db
(list (cons 90 (length dv+)))
dv+))
(if c (setpropertyvalue e "Closed" 1)))
