;; By Joe Burke, Charles Alan Butler and VovKa at theswamp.
;; Version 1.0 - 5/28/2008.
;; Find the minimum distance between two vlax-curve objects.
;; Supported object types: line, circle, arc, ellipse, polyline and spline.
;; Shortcut: MD

;; Little modified by Igal Averbuh 2016 (combined with subroutine to Draw length of minimum distance with user defined height of text)

;; Notes version 1.0:
;; If two lines are parallel they are reported as such.
;; If the Z values of the two points found are not equal,
;; report at command line Z1 = x Z2 = x. When the objects
;; are not coplanar, the apparent minimum distance will
;; usually differ from the actual minimum distance.
;; There's an option to add a line on the current layer
;; drawn between the two closest points.
;; The object types selected are reported at the command line.

;; Version history by Joe Burke:

;; Version 1.2 beta - 5/31/2008
;; Added the MinDistLine routine. Shortcut: MDL.
;; Allows the user to place a line between the last two closest points
;; calculated by MinDist after it ends. This avoids having to choose
;; whether a line is placed within MinDist itself. The idea is MinDist
;; is primarily a measuring tool. As such a minimum distance line is
;; rarely needed. Note, If the line drawn by MDL is off-screen it is
;; selected, otherwise not.

;; Version 1.3 beta - 6/8/2008
;; Added support for nested objects in blocks and xrefs.
;; Added MD:GetXrefs, MD:GetObject, MD:UnlockLayers, MD:RelockLayers
;; and MD:XMark sub-functions.
;; The first object selected is highlighted until the the second
;; object is selected similar to the fillet tool. If the first object
;; is contained in an xref it is not highlighted. Rather a temporary
;; X mark is placed where the object was selected to indicate the
;; the object is contained in an xref.

;; Version 1.4 beta - 6/10/2008
;; Added error checking for non-uniformly scaled blocks.

;; Version 1.4a - 6/21/2008
;; Bug fix for 2D (heavy) and 3D polylines.
;; Bug fix to avoid error if a dimension is selected.
;; Revised report when the Z values of the two points are not the same.

;;; Draw length of multi Lines, Arcs, Circles and Ellipses as Masked Mtext
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?56656-Lisp-help-Selecting-multi-lines-and-labeling-them/page2

(defun c:lm(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid lCol
cLay nTxt Precision Suffix BackMask Layer Color)

; *****************************************************************************
; ADJUSTMENTS ;
; (Modify it to adjust for your own requirements) ;
; *****************************************************************************

(setq Precision 1) ; - precision of measurement (digits after decimal point)

(setq Suffix "m") ; - Suffix after measirement for ex. "'" or "" for none

(setq BackMask 1.0) ; - Background mask borders from 1.0 to 10.0
; or nil for none. Reocomended value 1.0.
; !!! nil for versions ealer AutoCAD 2005 !!!

(setq Layer "0-Length-Calculation") ; - layer of markers or nil for current layer

(setq Color 1) ; - color of layer for ex. 1 (Red)

; ******************************* END ADJUSTMENTS *****************************

(vl-load-com)

(defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
/ oOsn cLay cTxt actSp nTxt
oDxf nDxf mPt xPt aDoc aSp lFlg)

; (Add_Masked_MText )

(setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
(vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
); end setq
(if(= 1 aSp)
(setq aSp(vla-get-ModelSpace aDoc))
(setq aSp(vla-get-PaperSpace aDoc))
); end if
(if(= :vlax-true(vla-get-Lock cLay))
(progn
(vla-put-Lock cLay :vlax-false)
(setq lFlg T)
); end progn
); end if
(if(= 1.0 wiF)
(setq cTxt(strcat "\\pxqc;" Str))
(setq cTxt(strcat "\\pxqc;{\\W" (rtos wiF) ";" Str "}"))
); end if
(setq nTxt(vla-AddMText aSp
(vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
(if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
); end setq
(entmod nDxf)
); end progn
); end if
(vla-getBoundingBox nTxt 'mPt 'xPt)
(setq mPt(vlax-safearray->list mPt)
xPt(vlax-safearray->list xPt)
mPt(vlax-3d-point
(list(+(car mPt)(/(-(car xPt)(car mPt))2))
(+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
0.0))
); end setq
(vla-Move nTxt mPt(vlax-3D-point Pt))
(if(and(> Ang 0)(<= Ang pi))
(vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
(vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
); end if
(if lFlg
(vla-put-Lock cLay :vlax-true)
); end if
nTxt
); end of Add_Masked_MText

(if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
(setq oldSize lab:Size
lab:Size
(getdist
(strcat "\nText size : ")))
(if(null lab:Size)(setq lab:Size oldSize))
; (princ "\n<> ")
(if(setq lSet(ssget "L"))
(progn
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
lCol(vla-get-Layers aDoc)
); end setq
(vla-StartUndoMark aDoc)
(if Layer
(if(vl-catch-all-error-p
(vl-catch-all-apply
'vla-Item(list lCol Layer)))
(progn
(setq cLay(vla-Add lCol Layer))
(vla-put-Color cLay Color)
); end progn
); end if
); end if
(foreach l(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam l)
ePar(vlax-curve-getEndParam l)
eLen(-(vlax-curve-getDistAtParam l ePar)
(vlax-curve-getDistAtParam l sPar))
lPnt(vlax-curve-getPointAtDist l(/ eLen 2))
iDr(vlax-curve-getFirstDeriv l
(vlax-curve-getParamAtPoint l lPnt))
iAng(- pi
(atan
(/(car iDr)
(if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
cTxt(strcat(rtos eLen 2 Precision)Suffix)
tWid(caadr
(textbox
(list(cons 1 cTxt)
(cons 40 lab:Size)(cons 41 0.8))))
); end setq
(setq nTxt(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng BackMask))
(if Layer
(vla-put-Layer nTxt Layer)
); end if
(vla-EndUndoMark aDoc)
); end foreach
); end progn
(princ "\n Nothing selected ")
); end if
(princ)
); end of c:lmark

(defun c:FMD ( / *error* doc blocks units obj1 obj2 typ1 typ2 pkpt p2
div fuzz d bd len inc idx resdist dellst res1 res2
blk locklst interflag z1 z2 diff MD:Wait MD:NormalAngle
MD:ParallelLines MD:Pick MD:GetXrefs MD:UnlockLayers
MD:RelockLayers MD:GetObject MD:XMark MD:UniformScale)
;; global vars: *mdp1* and *mdpt*

(vl-load-com)

(defun *error* (msg)
(cond
((not msg))
((wcmatch (strcase msg) "*QUIT*,*CANCEL*"))
(T (princ (strcat "\nError: " msg)))
)
(setvar "lunits" units)
(if
(and
obj1
(not (vlax-erased-p obj1))
)
(vla-highlight obj1 acFalse)
)
(MD:Wait 0.2)
(redraw)
(foreach x dellst (vla-delete x))
(MD:RelockLayers locklst)
(princ)
) ;end error

;;; START SUB-FUNCTIONS ;;;

;; Unlock locked layers.
;; Argument: document object.
;; Returns a list of layer objects which were locked,
;; or nil if none are locked.
;; Typically the function filters out xref layers,
;; but not in this case.
(defun MD:UnlockLayers (doc / laylst)
(vlax-for x (vla-get-Layers doc)
(if (eq :vlax-true (vla-get-lock x))
(progn
(setq laylst (cons x laylst))
(vla-put-lock x :vlax-false)
)
)
)
laylst
) ;end

;; Argument: a list of layer objects from UnlockLayers above.
;; Use vl-catch-all-apply in case a locked
;; layer was deleted in the calling function.
(defun MD:RelockLayers (lst)
(foreach x lst
(vl-catch-all-apply 'vla-put-lock (list x :vlax-true))
)
) ;end

(defun MD:GetXrefs (blklst / lst)
(if (vl-every '(lambda (x) (= (type x) 'ENAME)) blklst)
(foreach blk (mapcar 'vlax-ename->vla-object blklst)
(if (vlax-property-available-p blk 'Path)
(setq lst (cons blk lst))
)
)
)
(reverse lst)
) ;end

(defun MD:Wait (seconds / stop)
(setq stop (+ (getvar "DATE") (/ seconds 86400.0)))
(while (> stop (getvar "DATE"))
(princ)
)
) ;end

;; Argument: angle in radians, any number including negative.
;; Returns: normalized angle in radians between zero and (* pi 2)
(defun MD:NormalAngle (a)
(if (numberp a)
(angtof (angtos a 0 14) 0))
) ;end

;; Returns T if two lines are parallel.
(defun MD:ParallelLines (line1 line2 fuzz / ang1 ang2)
(setq ang1 (MD:NormalAngle (vlax-get line1 'Angle))
ang2 (MD:NormalAngle (vlax-get line2 'Angle))
)
(or
(equal ang1 ang2 fuzz)
(equal ang1 (MD:NormalAngle (+ pi ang2)) fuzz)
(equal ang2 (MD:NormalAngle (+ pi ang1)) fuzz)
(equal (MD:NormalAngle (+ pi ang1)) (MD:NormalAngle (+ pi ang2)) fuzz)
)
) ;end

(defun MD:Pick (msg / typlst e obj typ scflag)
(setq typlst '("AcDbLine" "AcDbArc" "AcDbCircle" "AcDbEllipse"
"AcDbPolyline" "AcDb2dPolyline" "AcDb2dVertex"
"AcDb3dPolyline" "AcDb3dPolylineVertex" "AcDbSpline"))
(while
(or
(not (setq e (nentselp msg)))
(not (setq obj (vlax-ename->vla-object (car e))))
(not (vl-position (setq typ (vlax-get obj 'ObjectName)) typlst))
(and
(cadddr e)
(not (apply 'and (mapcar 'MD:UniformScale (last e))))
(setq scflag T)
)
)
(cond
((not e)
(princ "\nMissed pick. ")
)
(scflag
(princ "\nNon-uniformly scaled block or dimension detected, try again. ")
(setq scflag nil)
)
(typ
(princ (strcat "\n " (substr typ 5) " selected, try again. "))
(setq typ nil)
)
)
)

(if
(or
(eq "AcDb2dVertex" typ)
(eq "AcDb3dPolylineVertex" typ)
)
(setq obj (vlax-ename->vla-object (cdr (assoc 330 (entget (car e)))))
typ (vlax-get obj 'ObjectName)
)
)

;; Used to mark xref. Point passed to MD:XMark.
;; The variable is local in the main routine.
(setq pkpt (cadr e))
(if (= 2 (length e))
(list obj typ)
(list obj typ (caddr e) (cadddr e))
)
) ;end

;; Argument: UCS point.
;; Returns: nil
(defun MD:XMark (pt / len p1 p2 p3 p4)
(setq len (/ (getvar "viewsize") 75.0)
p1 (polar pt (* pi 0.3) len)
p2 (polar pt (* pi 0.7) len)
p3 (polar pt (* pi 1.3) len)
p4 (polar pt (* pi 1.7) len)
)
(grdraw p1 p3 7)
(grdraw p2 p4 7)
)

;; Added error checking 6/21/2008.
(defun MD:UniformScale (obj / x y z)
(and
(or
(= (type obj) 'VLA-object)
(if (= (type obj) 'ENAME)
(setq obj (vlax-ename->vla-object obj))
)
)
(= "AcDbBlockReference" (vlax-get obj 'ObjectName))
(setq x (vlax-get obj 'XScaleFactor))
(setq y (vlax-get obj 'YScaleFactor))
(setq z (vlax-get obj 'ZScaleFactor))
(and
(equal (abs x) (abs y) 1e-8)
(equal (abs y) (abs z) 1e-8)
)
)
)

;; Argument: a list returned by MD:Pick.
;; Returns: a vla-object. The first object in list if the object is
;; not nested. Otherwise a transformed copy of the object.
(defun MD:GetObject (lst / blkref blk obj)
(cond
;; Object is not nested.
((= 2 (length lst))
(setq obj (car lst))
)
;; Object is nested in an xref. Copy it within the xref database.
;; The owner is not specified within the CopyObjects function.
((setq blkref (car (MD:GetXrefs (last lst))))
(setq blk (vla-item blocks (vlax-get blkref 'Name)))
(setq obj
(car
(vlax-invoke
(vlax-get blk 'XRefDatabase) 'CopyObjects (list (car lst)))))
(vla-transformby obj (vlax-tmatrix (caddr lst)))
(setq dellst (cons obj dellst))
;; Grdraw X mark on xref where it was selected
;; if it is the first object selected.
(if (not obj1) (MD:XMark pkpt))
)
;; Object is nested in a block reference.
;; Copy it from the block and highlight in the main
;; routine if it is the first object selected.
(T
(setq obj
(car (vlax-invoke doc 'CopyObjects (list (car lst))
(vlax-get (vla-get-ActiveLayout doc) 'Block))))
(vla-transformby obj (vlax-tmatrix (caddr lst)))
(setq dellst (cons obj dellst))
)
)
obj
) ;end

;;; END SUB-FUNCTIONS ;;;

;;; START MAIN FUNCTION ;;;

(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
blocks (vla-get-Blocks doc)
locklst (MD:UnlockLayers doc)
units (getvar "lunits")
)

(princ "\nSelect line, circle, arc, ellipse, polyline or spline. ")

(if
(and
(setq res1 (MD:Pick "\nFirst object: "))
(setq typ1 (cadr res1))
(princ (substr typ1 5))
(setq obj1 (MD:GetObject res1))
(not (vla-highlight obj1 acTrue))
(setq res2 (MD:Pick "\nSecond object: "))
(setq typ2 (cadr res2))
(princ (substr typ2 5))
(setq obj2 (MD:GetObject res2))
)
(progn
(cond
((equal obj1 obj2)
(princ "\n Same object selected twice. ")
(setq resdist 0.0
interflag T
)
)
((vlax-invoke obj1 'IntersectWith obj2 acExtendNone)
(princ "\n Objects intersect. ")
(setq resdist 0.0
interflag T
)
)
;; Calculate minimum distance.
(T
(setq idx 0
len (vlax-curve-getDistAtParam obj1 (vlax-curve-getEndParam obj1))
;; Seems more than sufficient.
div 200
inc (/ len div)
fuzz 1e-8
)
;; Check the first object selected for the closest point
;; on the second object.
(setq bd
(distance
(setq *mdp1* (vlax-curve-getPointAtDist obj1 idx))
(vlax-curve-getClosestPointTo obj2 *mdp1*)
)
)
(repeat (1+ div)
(if
(and
(setq *mdp1* (vlax-curve-getPointAtDist obj1 idx))
(setq p2 (vlax-curve-getClosestPointTo obj2 *mdp1*))
)
(progn
(setq d (distance *mdp1* p2))
(setq idx (+ idx inc))
(if (<= d bd)
(setq bd d *mdpt* *mdp1*)
)
)
)
)
;; Refine the minimum distance as needed. Start with closest
;; point on first object. Bounce the closest points back and
;; forth between the two objects until delta distance is less
;; than the fuzz factor.
(while
(not
(minusp
(- (distance *mdpt*
(setq *mdp1* (vlax-curve-GetClosestPointTo obj2 *mdpt*)))
(setq d
(distance *mdp1*
(setq *mdpt* (vlax-curve-GetClosestPointTo obj1 *mdp1*))))
fuzz
)
)
)
)
(if (and d *mdpt* *mdp1*)
(progn
(setq resdist d)
(grdraw (trans *mdpt* 0 1) (trans *mdp1* 0 1) -7 1)
)
)
(if
(and
(eq "AcDbLine" typ1)
(eq "AcDbLine" typ2)
(MD:ParallelLines obj1 obj2 1e-8)
)
(princ "\n Lines are parallel. ")
)

;; Check the Z values of the two closest points.
(setq z1 (caddr *mdpt*) z2 (caddr *mdp1*) diff (abs (- z1 z2)))
(cond
((equal z1 z2 1e-10))
;; Units are scientific, decimal or engineering.
(( units 3)
(< diff 0.00196)
)
(princ
(strcat "\n Z values of the points differ by: "
(rtos diff (setvar "lunits" 2) 10)
)
)
(setvar "lunits" units)
)
;; Otherwise display diff in architectural or fractional units.
(T
(princ
(strcat "\n Z values of the points differ by: "
(rtos diff)
)
)
)
) ;cond
)
) ;cond
) ;progn
) ;if

(if resdist
(progn
(princ (strcat "\n Distance: " (rtos resdist)))
(if (not interflag)
(princ " Enter MDL to place a minimum distance line. ")
)
)
(princ "\n Could not calculate minimum distance. ")
)
(*error* nil)
) ;end MinDist

;shortcut
(defun c:MD () (c:MinDist))

(defun c:MDL ( / sc ss MDL:PointInside MDL:GetScreenCoords)

;; Arguments:
;; p1 - WCS or UCS point which defines the first corner of area
;; p2 - WCS or UCS point which defines the second corner of area
;; pt - point translated to UCS.
;; Returns: T if pt falls within area
(defun MDL:PointInside (p1 p2 pt / xval yval)
(and
pt
(setq pt (trans pt 0 1)
xval (car pt)
yval (cadr pt)
)
(< (min (car p1) (car p2)) xval (max (car p1) (car p2)))
(< (min (cadr p1) (cadr p2)) yval (max (cadr p1) (cadr p2)))
)
) ;end

;; Returns the coordinates of the current view, lower left and upper right.
;; Works in a rotated view. Returns a list of two 2D UCS points.
(defun MDL:GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
(setq ViwSiz (/ (getvar "VIEWSIZE") 2.0)
ViwCen (getvar "VIEWCTR")
ViwDim (list
(* ViwSiz (apply '/ (getvar "SCREENSIZE")))
ViwSiz
)
VptMin (mapcar '- ViwCen ViwDim)
VptMax (mapcar '+ ViwCen ViwDim)
)
(list VptMin VptMax)
) ;end

(if
(and
*mdpt* *mdp1*
(not (equal *mdpt* *mdp1* 1e-6))
(entmake
(list
'(0 . "LINE")
(cons 8 (getvar "clayer"))
(cons 10 *mdpt*)
(cons 11 *mdp1*)
)
)
)
(progn
(setq sc (MDL:GetScreenCoords))
(if
(or
(MDL:PointInside (car sc) (cadr sc) *mdpt*)
(MDL:PointInside (car sc) (cadr sc) *mdp1*)
)
(princ "\n Minimum distance line placed. ")
(progn
(princ "\n Minimum distance line placed off screen and selected. ")
(sssetfirst nil (setq ss (ssget "L")))
)
)
)
(princ "\n Minimum distance line not found. Run MD and then MDL to draw line")
)
(princ)
) ;end

(defun c:MD ()
(c:fmd)
(c:mdl)
(c:lm)
)

(c:md)

Advertisements