;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, Espa?a.
;;; Copyright © 2012-2020 by Reinaldo N. Togores. All rights reserved.
;;; Use of this code is allowed mentioning the book and its author.
;;;Chapter 15. VLAX-CURVE... measuring curves and something else
(defun ax-curvelength (curveobj)
(vlax-curve-GetDistAtParam
curveobj
(vlax-curve-GetEndParam curveobj)))
;;;Listing 15.1. Obtaining the total length of a curve.
(defun C:READ-LENGTH (/ obj)
(if (setq obj (car (entsel "\nCurve to measure:")))
(alert
(strcat "The object "
(cdr (assoc 0 (entget obj)))
" measures\n"
(vl-princ-to-string
(ax-curvelength (vlax-ename->vla-object obj)))
" length units."))
(alert "No object selected.")))
;;;Listing 15.2. Test function for AX-CURVELENGTH.
(defun ax-dist-point (curveObj pt / param)
(if (setq param
(vlax-curve-GetParamAtPoint curveObj (trans pt 1 0)))
(vlax-curve-GetDistAtParam curveObj param)))
;;;Listing 15.3. Length along the curve to any point.
(defun C:DIST-TO-POINT (/ obj pt dist)
(prompt "\nSelect curve to measure: ")
(cond
((setq obj (car (entsel)))
(setq obj (vlax-ename->vla-object obj)
dist (ax-dist-point obj (getpoint "\nSelect point: ")))
(alert (if dist
(strcat
"\nDistance from starting point"
"\nto selected point is\n"
(rtos dist 2 2))
"The point is not on the object")))
(t (alert "No object selected"))))
;;;Listing 15.4. Measuring the distance from the beginning of the curve to a point.
(defun ax-dist-betweenpoints
(curveobj pt1 pt2 / dist1 dist2)
(if (and (setq dist1 (ax-dist-point curveobj pt1))
(setq dist2 (ax-dist-point curveobj pt2)))
(abs (- dist1 dist2))))
;;;Listing 15.5. Determining the distance between two points on the curve.
(defun C:DIST-BETWEEN-POINTS (/ obj pt1 pt2 dist)
(prompt "\nSelect curve to measure: ")
(if (and (setq obj (car (entsel)))
(setq pt1 (getpoint "\nPoint 1: "))
(setq pt2 (getpoint "\nPoint 2: "))
(setq dist
(ax-dist-betweenpoints
(vlax-ename->vla-object obj)
pt1
pt2)))
(alert (strcat "\nThe distance between the points"
"\nequals \n"
(rtos dist 2 2)))
(alert (if (null obj)
"No object selected"
"The point is not on the object"))))
;;;Listing 15.6. Program that measures the distance between two points along a curve.
(defun C:CURVE-AREA (/ obj name)
(while (setq obj (car (entsel)))
(setq obj (vlax-ename->vla-object obj)
name (vlax-get-property obj "ObjectName"))
(cond
((not (vlax-property-available-p obj "Area"))
(alert
(strcat "The selected object "
name
"\ndoes NOT have area.")))
((not (vlax-curve-isPlanar obj))
(alert
(strcat "The selected object "
name
"\nis NOT planar.")))
((not (vlax-curve-isClosed obj))
(alert
(strcat "The selected object "
name
"\nis NOT closed.")))
(t
(alert
(strcat "The selected object "
name
"\nhas an Area of "
(rtos (vlax-curve-GetArea obj))
" square units."))))))
;;;Listing 15.7. Determining the area enclosed by the curve.
(defun ent-ray (pt vector)
(entmake (list '(0 . "RAY")
'(100 . "AcDbEntity")
'(100 . "AcDbRay")
(cons 10 pt)
(cons 11 vector))))
;;;Listing 15.8. Function that draws a RAY.
(defun calc-tangent (ename-curve pt / dir curveobj param)
(setq dir (trans (getvar "viewdir") 1 0 t)
pt (trans pt 1 0))
(if (and (setq curveobj (vlax-ename->vla-object ename-curve))
(setq pt (vl-catch-all-apply
'vlax-curve-GetClosestPointToProjection
(list curveobj pt dir))))
(if (vl-catch-all-error-p pt)
nil
(progn (setq param (vlax-curve-GetParamAtPoint curveobj pt))
(list pt (vlax-curve-GetFirstDeriv curveobj param))))))
;;;Listing 15.9. Function that calculates the tangent to a curve.
(defun C:TANGENT (/ selection data)
(cmd-in)
(if (setq selection (entsel "\nSpecify point of tangency: "))
(if (setq data (calc-tangent (car selection) (cadr selection)))
(ent-ray (car data) (cadr data))
(prompt "\nRuntime error.")))
(cmd-out)
(princ))
;;;Listing 15.10. Command that draws a RAY tangent to a curve.
(defun cmd-vectorz (pt vector /)
(setvar "CMDECHO" 0)
(vl-cmdf "._ucs"
"_zaxis"
"_none"
(trans pt 0 1)
"_none"
(trans (mapcar '+ pt vector) 0 1))
(setvar "CMDECHO" 1))
;;;Listing 15.11. Function that sets a coordinate system from a point and a vector using command.
(defun ax-normal-ucs (origin vec-z / ang vec-x vec-y)
(setq ang (- (angle '(0 0 0) vec-z) (/ pi 2))
vec-X (vec '(0 0 0) (polar '(0 0 0) ang 1.0))
vec-Y (vec-prod vec-z vec-x))
(vla-put-ActiveUCS
*aevl:drawing*
(ax-ucs "TMP" origin vec-x vec-y)))
;;;Listing 15.12. UCS from the Z axis direction vector using ActiveX.
(defun ax-UCSMatrix (origin vec-z / ang vec-x vec-y)
(setq ang (- (angle '(0 0 0) vec-z) (/ pi 2))
vec-X (vec '(0 0 0) (polar '(0 0 0) ang 1.0))
vec-Y (vec-prod vec-z vec-x))
(vla-GetUCSMatrix (ax-ucs "TMP" origin vec-x vec-y)))
;;;Listing 15.13. Function that returns a UCS transformation matrix.
(defun C:NORMAL-UCS (/ selection data)
(if (setq selection (entsel "\nOrigin point on curve: "))
(if (setq data (calc-tangent (car selection) (cadr selection)))
(ax-normal-ucs (car data) (cadr data))
(prompt "\nRuntime error.")))
(princ))
;;;Listing 15.14. Command to establish a UCS perpendicular to a curve.
(defun ax-measure (obj dist / len step tmp)
(setq len (ax-curvelength obj)
step dist)
(while (<= step len)
(setq tmp (cons (vlax-curve-GetPointAtDist obj step) tmp)
step (+ step dist)))
(reverse tmp))
;;;Listing 15.15. Calculating points at fixed distances.
(defun C:BREAK-DIST (/ sset ent obj dist points)
(vla-StartUndoMark *aevl:drawing*)
(prompt "\nSelect curve to break: ")
(while
(not (and (setq sset (ssget "_:S" '((0 . "*LINE,ARC,HELIX"))))
(not (vlax-curve-isClosed (ssname sset 0)))))
(prompt "\nSelect an open curve: "))
(setq ent (ssname sset 0)
obj (vlax-ename->vla-object ent))
(initget (+ 1 2 4 128) "Distance")
(setq dist (getint "\nNumber of segments or [Distance]:"))
(cond ((= (type dist) 'STR)
(initget (+ 1 2 4))
(setq dist (getreal "\nSegment length:")))
(t
(setq dist (/ (vlax-curve-GetDistAtParam
obj
(vlax-curve-GetEndParam obj))
dist))))
(setq points (ax-measure obj dist))
(cmd-in)
(foreach pt points
(vl-cmdf "_BREAK"
(list ent (trans pt 0 1))
"_F"
(trans pt 0 1)
"@")
(setq ent (entlast)))
(cmd-out)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 15.16. Breaking an entity into equal segments.
(defun coord->points (lst ext / i points)
(setq i 0)
(while (< i ext)
(setq points (cons (list (nth (- ext (+ i 2)) lst)
(nth (- ext (+ i 1)) lst)
(nth (- ext i) lst))
points)
i (+ i 3)))
points)
;;;Listing 15.17. Creating a points list from a list of coordinates.
(defun ext-mode (mode)
(cond ((null mode) acExtendNone)
((eq mode T) acExtendBoth)
(t mode)))
;;;Listing 15.18. Determining how to extend the entities.
(defun intersections (obj1 obj2 mode / crossing limit pti)
(setq crossing (vl-catch-all-apply
'vla-IntersectWith
(list (vlax-ename->vla-object obj1)
(vlax-ename->vla-object obj2)
(ext-mode mode))))
(if (not (vl-catch-all-error-p crossing))
(progn
(setq pti (vlax-variant-value crossing))
(if (< (setq limit (vlax-safearray-get-u-bound pti 1)) 0)
nil
(coord->points (vlax-safearray->list pti) limit)))))
;;;Listing 15.19. INTERSECTIONS function.
No comments:
Post a Comment