;;; Creates Rectangle from 2 intersect line(pline) segments.
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?97285-Drawing-Rectangle-using-Perpendicular-Reference-Point-of-2-Polyline

(defun c:rl ( / int e1 e2 o1 o2 np1 np2 s1 s2 pt1 pt2 pt3 pt4 )
(if (and (setq e1 (LM:SelectIf "\nSelect 1st Line Segment: " (lambda (x) (wcmatch (cdr (assoc 0 (entget (car x)))) "LINE,*POLYLINE" )) entsel nil))
(setq e2 (LM:SelectIf "\nSelect 2nd Line Segment: " (lambda (x) (wcmatch (cdr (assoc 0 (entget (car x)))) "LINE,*POLYLINE" )) entsel nil))
)
(if (setq o1 (vlax-ename->vla-object (car e1))
o2 (vlax-ename->vla-object (car e2))
np1 (vlax-curve-getclosestpointto o1 (cadr e1))
np2 (vlax-curve-getclosestpointto o2 (cadr e2))
s1 (pjk-GetCurveSegment o1 np1)
s2 (pjk-GetCurveSegment o2 np2)
pt1 (car s1)
pt2 (cadr s1)
pt3 (car s2)
pt4 (cadr s2)
int (inters pt1 pt2 pt3 pt4)
)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 10 (mapcar '+ pt1 (mapcar '- pt3 int)))
(cons 10 (mapcar '+ pt1 (mapcar '- pt4 int)))
(cons 10 (mapcar '+ pt2 (mapcar '- pt4 int)))
(cons 10 (mapcar '+ pt2 (mapcar '- pt3 int)))
)
)
(princ "\nLines do not intersect.")
)
)
(princ)
)
;;---------------------=={ Select if }==----------------------;;
;; ;;
;; Provides continuous selection prompts until either a ;;
;; predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; msg - prompt string ;;
;; pred - optional predicate function [selection list arg] ;;
;; func - selection function to invoke ;;
;; keyw - optional initget argument list ;;
;;------------------------------------------------------------;;
;; Returns: Entity selection list, keyword, or nil ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'STR (type sel))
nil
)
( (vl-consp sel)
(if (and pred (not (pred sel)))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
sel
)
;; Modified version by PJK originally written by: Stig Madsen
;; refer to thread titled "relaxed-curves" under the "Teach Me"
;; section of TheSwamp at http://www.theswamp.org/phpBB2/
(defun pjk-GetCurveSegment (obj pt / cpt eParam stParam)
(cond
((wcmatch (vlax-get-Property obj 'objectName) "AcDbLine,AcDbArc")
(setq eParam (vlax-curve-getEndParam obj)
stParam (vlax-curve-getStartParam obj)
)
(list
(vlax-curve-getPointAtParam obj stParam)
(vlax-curve-getPointAtParam obj eParam)
)
)
((setq cpt (vlax-curve-getClosestPointTo obj pt))
(setq eParam (fix (vlax-curve-getEndParam obj)))
(if (= eParam (setq stParam (fix (vlax-curve-getParamAtPoint obj cpt))))
(setq stParam (1- stParam))
(setq eParam (1+ stParam))
)
(list
(vlax-curve-getPointAtParam obj stParam)
(vlax-curve-getPointAtParam obj eParam)
)
)
)
)
(c:rl)

Advertisements