;;; ------------------------------------------------------------------------
;;; DistanceInquiry.lsp v2.1
;;;
;;; Copyright© 04.16.09
;;; Alan J. Thompson (alanjt)
;;;
;;; Contact: alanjt @ TheSwamp.org, CADTutor.net
;;;
;;; Permission to use, copy, modify, and distribute this software
;;; for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appears in all copies and
;;; that both that copyright notice and the limited warranty and
;;; restricted rights notice below appear in all supporting
;;; documentation.
;;;
;;; The following program(s) are provided "as is" and with all faults.
;;; Alan J. Thompson DOES NOT warrant that the operation of the program(s)
;;; will be uninterrupted and/or error free.
;;;
;;; Calculate horizontal & slope distance, bearing, delta X, Y & Z,
;;; percent slope between two selected points and Northing & Easting
;;; for picked points.
;;;
;;; The following objects may be selected for X,Y,Z:
;;; Arc, Block, Civil 3D Point, Civil 3D Surface, Circle, Ellipse,
;;; Land Desktop Point, AutoCAD Point
;;; * * If C3D surface is selected, user has option to pick point * *
;;; * * within surface and the true elevation is extracted. * *
;;;
;;; Points and bearing are translated to World UCS.
;;;
;;; * * * May be executed transparently * * *
;;;
;;; Revision History:
;;;
;;; v1.1 (04.23.09) 1. Added display of Delta X, Delta Z elevations, slope
;;; distance and Northing & Easting for picked points.
;;; 2. Added subroutines: AT:Arrow and AT:Midpoint
;;; 3. If slope between points is found, direction of
;;; flow is shown.
;;;
;;; v1.2 (04.28.09) 1. Added display of points' elevations, if applicable.
;;; 2. Updated 'AT:Arrow' subroutine.
;;; 3. Added check for elevation calculations to see if
;;; elevations for points are different.
;;;
;;; v1.3 (05.04.09) 1. Added subroutine 'AT:PointSameXY' and check to see
;;; if points are not at the same location, before
;;; calculating any slope information.
;;;
;;; v1.4 (05.12.09) 1. Added display of inquiry information with popup
;;; window, using DosLib. If user has DosLib loaded,
;;; information will display here aswell (must uncomment).
;;;
;;; v1.5 (09.23.09) 1. Added display of inches for flat distance portion. *OMITTED v1.8a*
;;;
;;; v1.6 (09.24.09) 1. Fixed issue with trying to set 'osnapz' on older versions.
;;;
;;; v1.7 (09.24.09) 1. Added display of azimuth.
;;;
;;; v1.8a(11.04.09) 1. Fixed (hopefully) coding to account for user units and luprec setttings.
;;; Added subroutine _RToS to properly set Lunits and Luprec values.
;;; 2. Added subroutine AT:DrawX and will display red "X" at first picked point.
;;; 3. Updated *error* routine.
;;; 4. Removed v1.5 update (stupid idea).
;;; 5. Added subroutines _GetPoint and AT:Entsel, now user has option to select
;;; an object in addition to picking a point.
;;; Accepted objects: C3D points, Point, Circle, Block
;;;
;;; v1.8b(11.17.09) 1. Added display of bearing in radians.
;;;
;;; v1.8c(11.18.09) 1. Added option to select arcs (will use point at radius).
;;;
;;; v1.9 (02.16.10) 1. Added Gradian display for angle between picked points.
;;;
;;; v2.0 (04.04.10) 1. Updated AT:DrawX subroutine.
;;; 2. Added option to select an Ellipse (in addition to other objects).
;;; Will use center point.
;;; 3. Fixed bug with running transparently.
;;;
;;; v2.1 (05.24.10) 1. Added option to select Civil 3D surface and extract elevation.
;;; 2. Replaced subroutine AT:Entsel with _sel. Now connecting line
;;; is drawn from first point to cursor (when in select mode).
;;; 3. When in select mode for second point, distance is dynamically
;;; displayed at the status line.
;;; 4. Fixed bug with "X" at first point not being displayed when
;;; in non-WCS.
;;; 5. Added option to select Land Desktop points.
;;;
;;; ------------------------------------------------------------------------
(defun c:D (/) (c:DistanceInquiry))
(defun c:DistanceInquiry (/ *error* AT:FlatDist AT:Arrow AT:Midpoint AT:PointSameXY AT:DrawX
_GetPoint #PromptString #AddString #OldOsnapz #Luprec #Lunits #Measure
#Arch _RToS #Point1 #Point2 #Bear #Rad #Angle #Grad #Dist #Elev #Slope
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; error handler
(defun *error* (#Message)
(and #OldOsnapz (setvar "osnapz" #OldOsnapz))
(grtext)
(and #Message
(not (wcmatch (strcase #Message) "*BREAK*,*CANCEL*,*QUIT*"))
(princ (strcat "\nError: " #Message))
) ;_ and
) ;_ defun
;;; Distance between 2 (no Z value) points
;;; Alan J. Thompson, 3.18.09
(defun AT:FlatDist (#Point1 #Point2)
(distance (list (car #Point1) (cadr #Point1))
(list (car #Point2) (cadr #Point2))
) ;_ distance
) ;_ defun
;;; Display directional arrow
;;; #Location - arrow placement point
;;; #Angle - arrow directional angle
;;; Alan J. Thompson, 04.28.09
(defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
(setq #Size (* (getvar "viewsize") 0.02)
#Point1 (polar #Location #Angle #Size)
#Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
#Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
) ;_ setq
(grvecs
(list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1)
) ;_ grvecs
) ;_ defun
;;; Midpoint between two points
;;; Alan J. Thompson, 04.23.09
(defun AT:Midpoint (#Point1 #Point2)
(mapcar '(lambda (x y)
(/ (+ x y) 2.0)
) ;_ lambda
#Point1
#Point2
) ;_ mapcar
) ;_ defun
;;;Check if two points are same X & Y (Z ignored)
;;;Return: T if same, nil if different
;;;Alan J. Thompson, 05.04.09
(defun AT:PointSameXY (#Point1 #Point2)
(equal (list (car #Point1) (cadr #Point1))
(list (car #Point2) (cadr #Point2))
0.00001
) ;_ equal
) ;_ defun
;;; Draw and "X" vector at specified point
;;; P - Placement point for "X"
;;; C - Color of "X" (must be integer b/w 1 & 255)
;;; Alan J. Thompson, 10.31.09
(defun AT:DrawX (P C / d n)
(if (and (vl-consp P)
(setq d (* (getvar "VIEWSIZE") 0.02))
) ;_ and
(progn (grvecs (cons C
(mapcar
(function (lambda (#) (polar P (* # pi) d)))
'(0.25 1.25 0.75 1.75)
) ;_ mapcar
) ;_ cons
) ;_ grvecs
P
) ;_ progn
) ;_ if
) ;_ defun
(defun _sel (pnt msg flt / gr e)
(while (and (setq gr (grread T 15 2))
(/= (car gr) 25)
(not (vl-position (cadr gr) '(13 158)))
(not e)
)
(redraw)
(and pnt (grtext -1 (rtos (distance pnt (cadr gr)))) (grdraw (AT:DrawX pnt 1) (cadr gr) 3 -1))
(princ (strcat "\r" msg))
(if (and (eq 3 (car gr))
(setq e (ssget (cadr gr)))
(wcmatch (cdr (assoc 0 (entget (setq e (ssname e 0))))) flt)
)
(setq e (vlax-ename->vla-object e))
(setq e nil)
)
)
(redraw)
(grtext)
e
)
(defun _GetPoint (#Point #Msg / _Get _ToList #Pnt #NoTrans #Obj #Value #N #E #Z sur pnt elev)
(setq _Get
(lambda (o p / c)
(if
(not (vl-catch-all-error-p (setq c (vl-catch-all-apply 'vlax-get-property (list o p))))
) ;_ not
c
) ;_ if
) ;_ lambda
) ;_ setq
(setq _ToList (lambda (v)
(if v
(vlax-safearray->list (vlax-variant-value v))
) ;_ if
) ;_ lambda
) ;_ setq
(initget 0 "Select sUrface")
(and
(if #Point
(setq #Pnt (getpoint #Point #Msg))
(setq #Pnt (getpoint #Msg))
) ;_ if
(cond
;; selected point
((vl-consp #Pnt)
(setq #Value #Pnt
#NoTrans T
) ;_ setq
)
;; sUrface
((eq "sUrface" #Pnt)
(if
(and
(setq *DI:Surface*
(cond (
;;; (AT:Entsel nil
;;; (strcat "\nSelect Civil 3D surface"
;;; (if *DI:Surface*
;;; " : "
;;; ": "
;;; )
;;; )
;;; '("V" (0 . "AECC_TIN_SURFACE"))
;;; nil
;;; )
(_sel #Point
(strcat "Select Civil 3D surface"
(if *DI:Surface*
(strcat " : "
)
": "
)
)
"AECC_TIN_SURFACE"
)
)
(*DI:Surface*)
)
)
(while (not elev)
(and
(setq pnt (if #Point
(getpoint #Point "\nSpecify point within C3D surface: ")
(getpoint "\nSpecify point within C3D surface: ")
)
)
(setq pnt (trans pnt 1 0))
(or
(> (setq elev (vlax-invoke *DI:Surface* 'FindElevationAtXY (car pnt) (cadr pnt)))
-99999.9
)
(setq elev (prompt "\nPoint outside of surface!"))
)
)
)
)
(setq #Value (list (car pnt) (cadr pnt) elev))
)
)
;; "Select" chosen
((eq "Select" #Pnt)
;;; (princ "\nAcceptable objects: ARC AECC_COGO_POINT CIRCLE ELLIPSE INSERT POINT")
(and
(setq #Obj
(_sel #Point
"Select object: "
"AECC_COGO_POINT,AECC_POINT,ARC,CIRCLE,ELLIPSE,INSERT,POINT"
)
)
;;; (setq
;;; #Obj (AT:Entsel nil
;;; nil
;;; '("V" (0 . "AECC_COGO_POINT,ARC,CIRCLE,ELLIPSE,INSERT,POINT"))
;;; nil
;;; ) ;_ AT:Entsel
;;; ) ;_ setq
(cond
;; aecc_cogo_point (civil 3d)
((eq "AeccDbCogoPoint" (_Get #Obj 'ObjectName))
(and (setq #E (_Get #Obj 'Easting))
(setq #N (_Get #Obj 'Northing))
(setq #Z (_Get #Obj 'Elevation))
(setq #Value (list #E #N #Z))
) ;_ and
)
;;AECC_POINT (land desktop)
((eq "AeccDbPoint" (_Get #Obj 'ObjectName))
(setq #Value (cdr (assoc 11 (entget (vlax-vla-object->ename #Obj)))))
)
;; circle
((vl-position (_Get #Obj 'ObjectName) '("AcDbArc" "AcDbCircle" "AcDbEllipse"))
(setq #Value (_ToList (_Get #Obj 'Center)))
)
;; insert
((eq "AcDbBlockReference" (_Get #Obj 'ObjectName))
(setq #Value (_ToList (_Get #Obj 'InsertionPoint)))
)
;; point
((eq "AcDbPoint" (_Get #Obj 'ObjectName))
(setq #Value (_ToList (_Get #Obj 'Coordinates)))
)
(T (setq #Value nil))
) ;_ cond
) ;_ and
)
) ;_ cond
) ;_ and
(cond
((and #Value #NoTrans) #Value)
((and #Value (not #NoTrans)) (trans #Value 0 1))
(T #Value)
) ;_ cond
) ;_ defun
;; custom rtos
(setq _RToS (lambda (x) (rtos x #Lunits #Luprec)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vl-load-com)
;; remove any existing arrows & set prompt string
(cond ((eq 1 (getvar 'cmdactive)) (setq #AddString "\n"))
(t (setq #AddString "") (vl-cmdf))
) ;_ cond
(redraw)
(setq #PromptString "\n-------------------------------------------------------")
;; fix osnapz to take actual elevation of points
(and (setq #OldOsnapz (getvar "osnapz")) (setvar "osnapz" 0))
;; retrieve LUPREC, LUNITS & MEASUREMENT settings
(setq #Luprec (getvar "luprec")
#Lunits (getvar "lunits")
#Measure (getvar "measurement")
) ;_ setq
;; account for architectural units (multiply by 12)
(if (and (eq 4 #Lunits) (zerop #Measure))
(setq #Arch 12)
(setq #Arch 1)
) ;_ if
(cond
((and (AT:DrawX (setq #Point1 (_GetPoint nil "\nSpecify first point [Select/sUrface]: ")) 1)
(setq #Point2 (_GetPoint #Point1 "\nSpecify next point [Select/sUrface]: "))
) ;_ and
;; clear "X"
(redraw)
;; points picked, calculation time
(setq #Point1 (trans #Point1 1 0)
#Point2 (trans #Point2 1 0)
#Rad (angle #Point1 #Point2)
#Bear (angtos #Rad 4 4)
#Angle (angtos #Rad 1 4)
#Grad (angtos #Rad 2)
#Dist (* #Arch (AT:FlatDist #Point1 #Point2))
) ;_ setq
;; calc & display Delta X, Y, Z
(setq #PromptString
(strcat #PromptString
"\nDelta X: "
(_RToS (- (car #Point2) (car #Point1)))
", Delta Y: "
(_RToS (- (cadr #Point2) (cadr #Point1)))
", Delta Z: "
(_RToS (- (caddr #Point2) (caddr #Point1)))
) ;_ strcat
) ;_ setq
;; display northing & easting for picked points
(setq #PromptString
(strcat #PromptString
"\nFrom: N="
(_RToS (cadr #Point1))
", E="
(_RToS (car #Point1))
" -> To: N="
(_RToS (cadr #Point2))
", E="
(_RToS (car #Point2))
) ;_ strcat
) ;_ setq
;; if points have elevation, % slope & slope distance calced, direction & point elevations displayed
(cond
((and (or (> (caddr #Point1) 0.)
(> (caddr #Point2) 0.)
) ;_ or
(not (AT:PointSameXY #Point1 #Point2))
(not (eq (caddr #Point1) (caddr #Point2)))
) ;_ and
(setq #Elev (- (caddr #Point2)
(caddr #Point1)
) ;_ -
#Slope (* 100. (/ #Elev #Dist))
) ;_ setq
(setq #PromptString
(strcat #PromptString
"\nSlope Distance: "
(_RToS (* #Arch (distance #Point1 #Point2)))
", Slope: "
(_RToS #Slope)
"% [From: "
(_RToS (caddr #Point1))
" -> To: "
(_RToS (caddr #Point2))
"]"
) ;_ strcat
) ;_ setq
;; draw directional arrow at midpoint between picked points
(AT:Arrow (trans (AT:Midpoint #Point1 #Point2) 0 1)
(if (> (caddr #Point1) (caddr #Point2))
(angle (trans #Point1 0 1) (trans #Point2 0 1))
(angle (trans #Point2 0 1) (trans #Point1 0 1))
) ;_ if
) ;_ AT:Arrow
)
) ;_ cond
;; bearing & distance b/w points
(setq #PromptString
(strcat #PromptString
"\nRad: "
(_RTos #Rad)
", Azm: "
#Angle
", Grad: "
#Grad
", Bear: "
#Bear
", Dist: "
(_RToS #Dist)
(if (and (< #Dist 6.1) (eq (strcase (getvar 'loginname)) "ATHOMPSON"))
(strcat " [" (_RToS (* #Dist 12.)) "in]")
""
) ;_ if
#AddString
) ;_ strcat
) ;_ setq
;; print everything to commandline & user dos_lib if applicable
(prompt #PromptString)
;;(and dos_traywnd (dos_traywnd "Distance Inquiry" #PromptString 360 100 "" 1500))
)
) ;_ cond
;; reset everything
(*error* nil)
(princ)
) ;_ defun
