;;; (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 17. Solid Modeling.
(defun cmd-cone (ctrbase baserad toprad dim-z /)
(cmd-in)
(vl-cmdf "._CONE" ctrbase baserad)
(if (/= toprad 0)
(vl-cmdf "_t" toprad dim-z)
(vl-cmdf dim-z))
(cmd-out))
;;;Listing 17.1. Creating a cone through command/vl-cmdf.
(defun ax-cone (control radius dim-z /)
(vla-AddCone
(current-space *aevl:drawing*)
(apply 'vlax-3d-point control)
radius
dim-z))
;;;Listing 17.2. Creation of a Cone primitive.
(defun ax-region (space-obj loops / profiles region)
(setq profiles (vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length loops))))
profiles (vlax-make-variant
(vlax-safearray-fill profiles loops))
region (vl-catch-all-apply
'vla-AddRegion
(list space-obj profiles)))
(cond
((vl-catch-all-error-p region)
(prompt (vl-catch-all-error-message region)))
(t
(if (> (getvar "DELOBJ") 0)
(foreach loop loops (vla-Delete loop)))
(vlax-safearray->list (vlax-variant-value region)))))
;;;Listing 17.3. Function that creates regions according to the profiles received.
(defun ax-boolean (obj1 operation obj2 / tmp)
(setq tmp (vl-catch-all-apply
'vla-Boolean
(list obj1 operation obj2)))
(if (vl-catch-all-error-p tmp)
(prompt (vl-catch-all-error-message tmp))
obj1))
;;;Listing 17.4. Function that performs a Boolean operation on two objects controlling errors.
(defun region-data (/ radmax)
(initget 1)
(setq center (getpoint "\nCenter of the region:"))
(initget (+ 1 2 4))
(setq extradius (getdist center "\nExterior Radius:"))
(initget (+ 1 2 4))
(setq numholes (getint "\nNumber of holes:")
distcenter (* 2 (/ extradius 3.0))
radmax (apply 'min
(list (/ (* pi distcenter) (* numholes 1.1))
(/ extradius 3.1))))
(initget (+ 1 2 4))
(setq holerad (getdist center "\nHole radius:"))
(while (>= holerad radmax)
(prompt
(strcat "\nHole radius must be less than "
(rtos radmax 2 2)))
(setq holerad (getdist center "\nHole radius:"))))
;;;Listing 17.5. Function that prompts for the complex region's data.
(defun C:COMP-REG (/ mtrans space-obj mtrans center extradius numholes distcenter
holerad origin normal cir-base base ang incang cir-holes holes)
(setq space-obj (current-space *aevl:drawing*))
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(region-data)
(setq origin (vlax-3d-point '(0 0 0))
normal (vlax-3d-point '(0.0 0.0 1.0))
cir-base (vla-AddCircle space-obj origin extradius))
(vla-put-Normal cir-base normal)
(setq base (car (ax-region space-obj (list cir-base))))
(setq ang 0
incang (/ (* 2 pi) numholes))
(repeat numholes
(setq cir-holes (cons
(vla-AddCircle
space-obj
(vlax-3d-point
(polar '(0 0 0) ang distcenter))
holerad)
cir-holes)
ang (+ ang incang))
(vla-put-Normal (car cir-holes) normal))
(setq holes (ax-region space-obj cir-holes))
(foreach hole holes (ax-boolean base acSubtraction hole))
(if mtrans
(vla-TransformBy base mtrans))
(ax-translation base (trans center 1 0 t))
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 17.6. Sample program that creates complex regions.
(defun base-reg (extradius numholes distcenter holerad / space-obj origin normal
cir-base base ang incang circles regions)
(setq space-obj (current-space *aevl:drawing*)
origin (vlax-3d-point '(0 0 0))
normal (vlax-3d-point '(0.0 0.0 1.0))
cir-base (vla-AddCircle space-obj origin extradius))
(vla-put-Normal cir-base normal)
(setq base (car (ax-region space-obj (list cir-base))))
(setq ang 0
incang (/ (* 2 pi) numholes))
(repeat numholes
(setq circles (cons
(vla-AddCircle
space-obj
(vlax-3d-point
(polar '(0 0 0) ang distcenter))
holerad)
circles)
ang (+ ang incang))
(vla-put-Normal (car circles) normal))
(setq regions (ax-region space-obj circles))
(foreach region regions
(ax-boolean base acSubtraction region))
base)
;;;Listing 17.7. Function that creates the base region.
(defun sol-hist (sol)
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History sol :vlax-true)))
;;;Listing 17.8. Enabling the Registry property in a 3DSolid.
(defun C:SOL-EXT (/ mtrans center extradius numholes holerad distcenter dim-z
amax angc circ profiles region extrusion)
(vla-startundomark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(region-data)
(initget 1)
(setq dimZ (getdist center "\nSpecify extrusion height: ")
amax (- 90.0 (rtd (atan (/ dimZ extradius)))))
(initget 1)
(setq taperangle (getreal "\nTaper angle:"))
(while (not (<= -90.0 taperangle amax))
(setq taperangle (getreal
(strcat
"\nAngle must be more than -90º and less than "
(rtos amax)
"º"))))
(setq region (base-reg extradius numholes distcenter holerad))
(setq taperangle (dtr taperangle)
extrusion (vl-catch-all-apply
'vla-addextrudedsolid
(list (current-space *aevl:drawing*)
region
dimZ
taperangle)))
(cond
((vl-catch-all-error-p extrusion)
(prompt (vl-catch-all-error-message extrusion)))
(t
(sol-hist extrusion)
(if mtrans
(vla-TransformBy extrusion mtrans))
(ax-translation extrusion (trans center 1 0 t))
(ax-SWt)))
(vla-endundomark *aevl:drawing*))
;;;Listing 17.9. Creating an Extruded Solid.
(defun ax-ext-path (space-obj profile path / res)
(if
(vl-catch-all-error-p
(setq res (vl-catch-all-apply
'vla-AddExtrudedSolidAlongPath
(list space-obj profile path))))
(princ (strcat "\nERROR: " (vl-catch-all-error-message res)))
(progn (sol-hist res) (vla-update res))))
;;;Listing 17.10. Auxiliary function ax-ext-path.
(defun C:SOL-PATH (/ space-obj path prof start normal ptref disp)
(setq space-obj (current-space *aevl:drawing*))
(vla-StartUndoMark *aevl:drawing*)
(while (not path)
(prompt
(strcat "\nSelect path "
"(Line, LWPolyline, Arc, Circle,"
" Ellipse, planar Spline): "))
(setq path (ssget "_:S"
'((-4 . ")
(0 . "SPLINE")
(-4 . "&")
(70 . 8)
(-4 . "AND>")
(0 . "LWPOLYLINE,LINE,ARC,ELLIPSE,CIRCLE")
(-4 . "AND>")
(-4 . "OR>")))))
(while (not prof)
(prompt "\nSelect a LWPloyline as profile. ")
(setq prof (ssget "_:S" '((0 . "LWPOLYLINE")))))
(setq path (vlax-ename->vla-object (ssname path 0))
prof (vlax-ename->vla-object (ssname prof 0)))
(if (= (vla-get-closed prof) :vlax-false)
(vla-put-closed prof :vlax-true))
(setq start (vlax-curve-GetPointAtParam
path
(vlax-curve-GetStartParam path))
normal (vlax-curve-GetFirstDeriv
path
(vlax-curve-GetStartParam path)))
(vla-TransformBy prof (ax-UCSMatrix start normal))
(setq ptref (append
(vlax-safearray->list
(vlax-variant-value
(vla-get-coordinate prof 0)))
(list (vla-get-elevation prof)))
ptref (trans ptref (vlax-vla-object->ename prof) 0)
disp (mapcar '- start ptref))
(ax-translation prof disp)
(setq prof (car (ax-region space-obj (list prof))))
(ax-ext-path space-obj prof path)
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 17.11. Creating a solid by sweeping along a path.
(defun cmd-base-helix ()
(cmd-in)
(vl-cmdf "_HELIX"
(trans '(0.0 0.0 0.0) 0 1)
(trans '(1.0 0.0 0.0) 0 1)
1.0
"_Turns"
1
"_Axis"
(trans '(0.0 0.0 1.0) 0 1))
(cmd-out)
(vlax-ename->vla-object (entlast)))
;;;Listing 17.12. Function that creates a HELIX object through command/vl-cmdf.
(defun ent-base-helix ()
(if
(entmake
'((0 . "HELIX")
(100 . "AcDbEntity")
(100 . "AcDbSpline")
(70 . 0)
(71 . 3)
(72 . 8)
(73 . 4)
(74 . 0)
(42 . 1.0e-010)
(43 . 1.0e-010)
(40 . 0.0)
(40 . 0.0)
(40 . 0.0)
(40 . 0.0)
(40 . 0.628319)
(40 . 0.628319)
(40 . 0.628319)
(40 . 0.628319)
(10 1.0 0.0 0.0)
(10 1.0 0.20944 0.0333333)
(10 0.932122 0.418345 0.0666667)
(10 0.809017 0.587785 0.1)
(100 . "AcDbHelix")
(90 . 31)
(91 . 8)
(10 0.0 0.0 0.0)
(11 1.0 0.0 0.0)
(12 0.0 0.0 1.0)
(40 . 1.0)
(41 . 0.1)
(42 . 1.0)
(290 . 1)
(280 . 1)))
(entlast)))
;;;Listing 17.13. Function that creates a HELIX by entmake.
(defun ax-helix (position height turns radiusbase radiustop / obj)
(if (setq obj (vlax-ename->vla-object (ent-base-helix)))
(progn (vla-put-Height obj height)
(vla-put-Turns obj turns)
(vla-put-BaseRadius obj radiusbase)
(vla-put-TopRadius obj radiustop)
(vla-put-Position obj (vlax-3d-point position))
obj)))
;;;Listing 17.14. Function that creates the Helix adjusting its ActiveX properties.
(defun prop-helix (position height turns radiusbase radiustop / obj)
(if (setq obj (ent-base-helix))
(progn (setpropertyvalue obj "Height" height)
(setpropertyvalue obj "Turns" turns)
(setpropertyvalue obj "BaseRadius" radiusbase)
(setpropertyvalue obj "TopRadius" radiustop)
(setpropertyvalue obj "Position" position))
obj))
;;;Listing 17.15. Function that creates the Helix adjusting its non-Com properties.
(defun spring-data (/ diamext diamwire)
(initget 1)
(setq center (getpoint "\nBase center"))
(initget (+ 1 2 4))
(setq diamext (getdist center "\nExterior diameter: "))
(initget (+ 1 2 4))
(setq height (getdist center "\nSpring length: "))
(initget (+ 1 2 4))
(while
(> (setq diamwire (getdist center "\nWire diameter: "))
(/ diamext 5.0))
(prompt
(strcat "\nThe wire diameter must be less than "
(rtos (/ diamext 5.0) 2 2)))
(initget (+ 1 2 4)))
(initget (+ 1 2 4))
(while
(> 1
(setq turns (getint "\nNumber of turns: "))
(fix (/ height (* diamwire 2))))
(prompt
(strcat "\nNumber of turns must be less than "
(itoa (fix (/ height (* diamwire 2))))))
(initget (+ 1 2 4)))
(setq radiuswire (/ diamwire 2.0)
radiusbase (- (/ diamext 2.0) radiuswire)))
;;;Listing 17.16. Function that prompts for the spring's data.
(defun cmd-sweep (profile path / ssprofile sspath res)
(cmd-in)
(setq ssprofile (ssadd)
sspath (ssadd))
(ssadd profile ssprofile)
(ssadd path sspath)
(vl-cmdf "._SWEEP" ssprofile "" sspath)
(cmd-out)
(setq res (vlax-ename->vla-object (entlast)))
(sol-hist res)
res)
;;;Listing 17.17. Function that creates a 3DSolid using the SWEEP command.
(defun C:SPRING (/ *error* mtrans space-obj mtrans center height turns
radiuswire radiusbase path ptref normal profile
profile-reg spring-obj)
(setq space-obj (current-space *aevl:drawing*))
(defun *error* ()
(cmd-out)
(vla-EndUndoMark *aevl:drawing*))
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(spring-data)
(setq path (ax-helix '(0 0 0) height turns radiusbase radiusbase)
ptref (vlax-curve-GetPointAtParam
path
(vlax-curve-GetStartParam path))
normal (vlax-curve-GetFirstDeriv
path
(vlax-curve-GetStartParam path))
profile (vl-catch-all-apply
'vla-AddCircle
(list space-obj
(vlax-3d-point ptref)
radiuswire)))
(cond
((vl-catch-all-error-p profile)
(prompt (vl-catch-all-error-message profile)))
(t
(vla-put-normal profile (vlax-3d-point normal))
(setq profile-reg (vlax-vla-object->ename
(car (ax-region space-obj (list profile))))
path (vlax-vla-object->ename path))
(setq spring-obj (cmd-sweep profile-reg path))
(if mtrans
(vla-TransformBy spring-obj mtrans))
(ax-translation spring-obj (trans center 1 0 t))
(vla-Update spring-obj)
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))))
;;;Listing 17.18. Main function C:SPRING.
(defun ax-sol-rev (space-obj profile pt vector ang / res)
(if
(vl-catch-all-error-p
(setq res (vl-catch-all-apply
'vla-AddRevolvedSolid
(list space-obj
profile
(vlax-3d-point pt)
(vlax-3d-point vector)
ang))))
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res)))
(progn (sol-hist res) (vla-Update res))))
;;;Listing 17.19. Function that creates a solid of revolution.
(defun C:SOL-REV (/ space-obj prof axis ang center vec)
(setq space-obj (current-space *aevl:drawing*))
(vla-StartUndoMark *aevl:drawing*)
(prompt "\nSelect the profile:")
(while
(not
(setq prof (ssget
"_:S"
'((0 . "REGION,LWPOLYLINE,SPLINE,CIRCLE,ELLIPSE")))))
(prompt "\nSelect a Region, 2D Polyline, Circle or Ellipse:"))
(prompt "\nSelect the revolution axis: ")
(while
(not
(setq axis (ssget "_:S"
(0 . "*LINE,ARC")
(-4 . ")
(-4 . "&")
(70 . 1)
(-4 . "NOT>;")
(-4 . "AND>")))))
(prompt "\nSelect an open lineal entity:"))
(initget (+ 2 4))
(if (not (setq ang (getreal "\nSweep angle <360>: ")))
(setq ang 360.0)
(while (> ang 360.0)
(initget (+ 2 4))
(setq ang (getreal "\nMust be less than 360 <360>:"))))
(setq prof (vlax-ename->vla-object (ssname prof 0)))
(if (/= (vla-get-ObjectName prof) "AcDbRegion")
(cond
((and (vlax-property-available-p prof "Closed")
(= (vla-get-Closed prof) :vlax-false))
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-Closed
(list prof :vlax-true)))
(vla-put-Closed2 prof :vlax-true)))))
(setq profiles (vlax-make-safearray vlax-vbObject '(0 . 0))
profiles (vlax-make-variant
(vlax-safearray-fill profiles (list prof)))
prof (vl-catch-all-apply
'vla-AddRegion
(list space-obj profiles)))
(cond
((vl-catch-all-error-p prof)
(prompt
(strcat "ERROR:\t" (vl-catch-all-error-message prof))))
(t
(setq prof (vlax-safearray-get-element
(vlax-variant-value prof)
0))
(setq ang (dtr ang)
axis (vlax-ename->vla-object (ssname axis 0)))
(if (= (vla-get-ObjectName axis) "AcDbXline")
(setq center (vlax-safearray->list
(vlax-variant-value
(vla-get-BasePoint axis)))
vec (vlax-safearray->list
(vlax-variant-value
(vla-get-DirectionVector axis))))
(setq center (vlax-curve-GetStartPoint axis)
vec (mapcar '- (vlax-curve-GetEndPoint axis) center)))
(ax-sol-rev space-obj prof center vec ang)
(ax-SWt)))
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 17.20. Sample program that creates a solid of revolution.
(defun ax-props (obj / props value pmin pmax bbox)
(setq props (vl-remove-if
'null
(mapcar
'(lambda (prop)
(if (vlax-property-available-p obj prop)
(progn
(setq value (vl-catch-all-apply
'vlax-get-property
(list obj prop)))
(if (not (vl-catch-all-error-p value))
(if (= (type value) 'variant)
(cond
((>= (vlax-variant-type value)
8192)
=
(cons
prop
(vlax-safearray->list
(vlax-variant-value
value))))
((t
(cons
prop
(vlax-variant-value
value)))))
(cons prop value))))))
'("Centroid" "MomentOfInertia" "PrincipalDirections"
"PrincipalMoments" "ProductOfInertia" "RadiiOfGyration" "Volume"
"Area" "Circumference" "Radius" "Center" "Normal" "Perimeter"
"Coordinates" "FaceCount" "VertexCount" "Smoothness" "Elevation"
"ArcLength" "EndAngle" "EndPoint" "StartAngle" "StartPoint"
"TotalAngle" "Angle" "Delta" "Thickness" "BasePoint"
"DirectionVector" "SecondPoint" "BaseRadius" "Height" "Position"
"TopRadius" "TotalLength" "TurnHeight" "Turns" "TurnSlope" "Twist"
"Direction" "TaperAngle" "EndDraftAngle" "EndDraftMagnitude"
"NumCrossSections" "NumGuidePaths" "StartDraftAngle"
"StartDraftMagnitude" "SurfaceNormals" "SurfaceType"
"RevolutionAngle" "AxisPosition" "AxisDirection" "ProfileRotation"
"Bank" "Length" "ProfileRotation" "scale"))))
(setq bbox (vl-catch-all-apply
'vla-GetBoundingBox
(list obj 'pmin 'pmax)))
(if (vl-catch-all-error-p bbox)
props
(setq props (cons
(list "BoundingBox"
(vlax-safearray->list pmin)
(vlax-safearray->list pmax))
props))))
;;;Listing 17.21. Function that extracts physical and geometric properties of objects.
No comments:
Post a Comment