;;; (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 18. Editing 3DSolids
(defun prop-hist (ent / rec shw)
(if
(=
(setq rec (value-with-options
'getkword
"Record History?: "
"Yes No"))
"No")
(setq rec 0)
(progn (setq rec 1)
(if
(=
(setq shw (value-with-options
'getkword
"Show History?: "
"Yes No"))
"No")
(setq shw 0)
(setq shw 1))))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("RecordHistory" "ShowHistory")
(list rec shw)))
;;;Listing 18.1. Setting the Record History properties.
(defun prop-box (ent prim / pos h l w)
(setq pos (default-value
'getpoint
(strcat "\nSelect new " prim " Position: ")
(getpropertyvalue ent "SolidPosition"))
h (default-value
'getdist
(strcat "\nSelect new " prim " Height: ")
(getpropertyvalue ent "Height"))
l (default-value
'getdist
(strcat "\nSelect new " prim " Length: ")
(getpropertyvalue ent "Length"))
w (default-value
'getdist
(strcat "\nSelect new " prim " Width: ")
(getpropertyvalue ent "Width")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("SolidPosition" "Height" "Length" "Width")
(list pos h l w)))
;;;Listing 18.2. Modifying a BOX 3DSolid.
(defun prop-cone (ent prim / pos h brmax brmin trmax trmin)
(setq pos (default-value
'getpoint
(strcat "\nSelect new " prim " Position: ")
(getpropertyvalue ent "SolidPosition"))
h (default-value
'getdist
(strcat "\nSelect new " prim " Height: ")
(getpropertyvalue ent "Height")))
(if (= (getpropertyvalue ent "Elliptical") 0)
(progn
(setq brmax (default-value
'getdist
(strcat "\nSelect new " prim " Base Radius: ")
(getpropertyvalue ent "BaseRadius"))
trmax (default-value
'getdist
(strcat "\nSelect new " prim " Top Radius: ")
(getpropertyvalue ent "TopRadius")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("SolidPosition" "Height" "BaseRadius" "TopRadius")
(list pos h brmax trmax)))
(progn
(setq brmax (default-value
'getdist
(strcat "\nSelect new "
prim
" Base Major Radius: ")
(getpropertyvalue ent "BaseMajorRadius")))
(while
(>
(setq brmin (default-value
'getdist
(strcat "\nSelect new "
prim
" Base Minor Radius: ")
(getpropertyvalue ent "BaseMinorRadius")))
brmax)
(prompt
(strcat "Minor Radius must be less than " (rtos brmax))))
(setq trmax (default-value
'getdist
(strcat "\nSelect new "
prim
" Top Minor Radius: ")
(getpropertyvalue ent "TopMinorRadius")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("SolidPosition" "Height" "BaseMajorRadius" "BaseMinorRadius"
"TopMinorRadius")
(list pos h brmax brmin trmax)))))
;;;Listing 18.3. Modifying a Cone primitive.
(defun prop-loft (ent prim / normtyp sda sdm eda edm)
(setq normtyp (value-with-options
'getkword
(strcat "Select " prim " Surface Normals type: ")
"Smooth First Last Ends All Draftangles Ruled"))
(cond
((= normtyp "Smooth") (setpropertyvalue ent "NormalType" 0))
((= normtyp "First") (setpropertyvalue ent "NormalType" 1))
((= normtyp "Last") (setpropertyvalue ent "NormalType" 2))
((= normtyp "Ends") (setpropertyvalue ent "NormalType" 3))
((= normtyp "All") (setpropertyvalue ent "NormalType" 4))
((= normtyp "Draftangles")
(setpropertyvalue ent "NormalType" 5)
(setq sda (dtr
(default-value
'getreal
(strcat "\nSelect new " prim " Start draft angle: ")
(rtd
(getpropertyvalue
ent
"LoftOptions/StartDraftAngle"))))
sdm (default-value
'getdist
(strcat "\nSelect new " prim " Start draft magnitude: ")
(getpropertyvalue
ent
"LoftOptions/StartDraftMagnitude"))
eda (dtr
(default-value
'getreal
(strcat "\nSelect new " prim " End draft angle: ")
(rtd
(getpropertyvalue
ent
"LoftOptions/EndDraftAngle"))))
edm (default-value
'getdist
(strcat "\nSelect new " prim " End draft magnitude: ")
(getpropertyvalue ent "LoftOptions/EndDraftMagnitude")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("LoftOptions/StartDraftAngle" "LoftOptions/StartDraftMagnitude"
"LoftOptions/EndDraftAngle" "LoftOptions/EndDraftMagnitude")
(list sda sdm eda edm)))
((= normtyp "Ruled") (setpropertyvalue ent "NormalType" 6))))
;;;Listing 18.4. Modifying a LOFT 3DSolid.
(defun C:SOL-PROPS (/ ent prim)
(setq ent (car (entsel)))
(if
(and (= (cdr (assoc 0 (entget ent))) "3DSOLID")
(= (getpropertyvalue ent "IsPrimitive") 1)
(setq prim (getpropertyvalue ent "SolidType")))
(cond
((= prim "Box")
(prop-box ent prim))
((= prim "Cone")
(prop-cone ent prim))
((= (substr prim 1 4) "Loft")
(prop-loft ent prim))
(t (prompt (strcat "\n" prim "is not supported! "))))
(prompt
(strcat "\nNot supported " (cdr (assoc 0 (entget ent))))))
(princ))
;;;Listing 18.5. 3DSolids property modification command.
(defun ax-slice (obj pt1 pt2 pt3 negative / res)
(setq res (vl-catch-all-apply
'vla-SliceSolid
(list obj
(vlax-3d-point pt1)
(vlax-3d-point pt2)
(vlax-3d-point pt3)
negative)))
(if (vl-catch-all-error-p res)
(prompt (vl-catch-all-error-message res))
res))
;;;Listing 18.6. Function that slices the 3DSolid.
(defun sol-p-data (/)
(initget 1 "Tetrahedron Hexahedron Dodecahedron")
(setq class (getkword
"\nPolyhedron [Tetrahedron/Hexahedron/Dodecahedron]: ")
center (getpoint "\nPolyhedron center: ")
radius (getdist center "\Circumscribed sphere radius: ")))
;;;Listing 18.7. Function-sol-p-data requesting user input.
(defun C:SOL-POLYHEDRON (/ mtrans class center radius sphere)
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(sol-p-data)
(op-polyhedron class)
(setq sphere (vl-catch-all-apply
'vla-AddSphere
(list (current-space *aevl:drawing*)
(vlax-3d-point '(0 0 0))
1.0)))
(cond
((vl-catch-all-error-p sphere)
(prompt (vl-catch-all-error-message sphere)))
(t
(sol-hist sphere)
(foreach face faces
(ax-slice
sphere
(nth (1- (car face)) vertices)
(nth (1- (cadr face)) vertices)
(nth (1- (caddr face)) vertices)
:vlax-false))
;; Transformations:
(ax-scale sphere (list radius radius radius))
(if mtrans
(vla-TransformBy sphere mtrans))
(ax-translation sphere (trans center 1 0 t))
(vla-Update sphere)
(ax-SWt)))
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 18.8. Main function C:SOL-POLYHEDRON.
(defun ax-sect (obj pt1 pt2 pt3 / res)
(setq res (vl-catch-all-apply
'vla-SectionSolid
(list obj
(vlax-3d-point pt1)
(vlax-3d-point pt2)
(vlax-3d-point pt3))))
(if (vl-catch-all-error-p res)
(prompt (vl-catch-all-error-message res))
res))
;;;Listing 18.9. Function that creates a solid's section as a REGION object.
(defun C:SECT-POLYHEDRON (/ mtrans class center radius sphere regions)
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(sol-p-data)
(op-polyhedron class)
(setq sphere (vl-catch-all-apply
'vla-AddSphere
(list (current-space *aevl:drawing*)
(vlax-3d-point '(0 0 0))
1.0)))
(cond
((vl-catch-all-error-p sphere)
(prompt (vl-catch-all-error-message sphere)))
(t
(sol-hist sphere)
(foreach face faces
(setq regions (cons
(ax-sect
sphere
(nth (1- (car face)) vertices)
(nth (1- (cadr face)) vertices)
(nth (1- (caddr face)) vertices))
regions)))
(if (> (getvar "DELOBJ") 0)
(vla-Delete sphere))
(foreach region regions ; Transformations
(ax-scale region (list radius radius radius))
(if mtrans
(vla-TransformBy region mtrans))
(ax-translation region (trans center 1 0 t)))
(ax-SWt)))
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 18.10. Main function C:SECT-POLYHEDRON.
(defun connector-data (/ maxdiam)
(setq origin '(0.0 0.0 0.0)
center (getpoint "\nSpecify connector's center: ")
gauge (getdist center "\nSpecify connector's gauge: ")
maxdiam (* gauge 2.5))
(initget (+ 2 4))
(while (or (not diam) (> diam maxdiam))
(setq diam (getreal
(strcat "\nHole diameter <"
(rtos (* gauge 2))
">: ")))
(cond
((not diam) (setq diam (* gauge 2)))
(t
(if (> diam maxdiam)
(prompt
(strcat
"\nThe hole's diameter must be smaller than "
(rtos maxdiam 2 2))))
(initget (+ 2 4)))))
(cond
((= (getvar "SOLIDHIST") 0)
(initget 1 "Yes No")
(if
(equal (getkword "\nRecord Solids history? [Yes/No]: ")
"Si")
(setvar "SOLIDHIST" 1)))))
;;;Listing 18.11. Connector data entry.
(defun ax-cube (center side / res)
(setq res (vl-catch-all-apply
'vla-AddBox
(list (current-space *aevl:drawing*)
(vlax-3d-point center)
side
side
side)))
(cond
((vl-catch-all-error-p res)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res))))
(t
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History res :vlax-true))
res)))
;;;Listing 18.12. Function used to create cubes as 3DSolids.
(defun ax-cylinder (center radius dim-z / res)
(setq res (vl-catch-all-apply
'vla-AddCylinder
(list (current-space *aevl:drawing*)
(vlax-3d-point center)
radius
dim-z)))
(cond
((vl-catch-all-error-p res)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res))))
(t
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History res :vlax-true))
res)))
;;;Listing 18.13. Function used to create cylinders as 3DSolids.
(defun rot-90-x (obj / ang)
(setq ang (/ pi 2))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list 1.0 0.0 0.0 0.0)
(list 0.0 (cos ang) (sin ang) 0.0)
(list 0.0 (- (sin ang)) (cos ang) 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 18.14. Function that rotates an object 90º about the X axis.
(defun rot-90-y (obj / ang)
(setq ang (/ pi 2))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos ang) 0.0 (sin ang) 0.0)
(list 0.0 1.0 0.0 0.0)
(list (- (sin ang)) 0.0 (cos ang) 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 18.15. Function that rotates an object 90º about the Y axis.
(defun delete-duplicates (lst / tmp)
(while lst
(setq tmp (cons (car lst) tmp)
lst (vl-remove-if
'(lambda (a) (equal a (car tmp) 0.0001))
lst)))
(reverse tmp))
;;;Listing 18.16. Function that removes duplicates from a list.
(defun C:CONNECTOR (/ mtrans origin center gauge side diam disp pos centers base dif)
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(connector-data)
(setq side (* gauge 7)
base (ax-cube origin side)
disp (list (/ side 2.0)
(/ side 2.0)
(/ side 2.0))
pos '((1 1 1)
(1 1 -1)
(1 -1 1)
(1 -1 -1)
(-1 1 1)
(-1 1 -1)
(-1 -1 1)
(-1 -1 -1))
centers (mapcar '(lambda (pt) (mapcar '* disp pt)) pos)
side (* gauge 6))
(mapcar
'(lambda (ctr)
(setq dif (ax-cube ctr side))
(vla-Boolean base acSubtraction dif))
centers)
(setq side (* gauge 2.0)
disp (list side side 0.0)
centers (delete-duplicates
(mapcar '(lambda (pt) (mapcar '* disp pt)) pos)))
(mapcar
'(lambda (ctr)
(setq dif (ax-cylinder ctr (/ diam 2.0) side))
(vla-Boolean base acSubtraction dif))
centers)
(mapcar
'(lambda (ctr)
(setq dif (ax-cylinder ctr (/ diam 2.0) side))
(rot-90-y dif)
(vla-Boolean base acSubtraction dif))
centers)
(mapcar
'(lambda (ctr)
(setq dif (ax-cylinder ctr (/ diam 2.0) side))
(rot-90-x dif)
(vla-Boolean base acSubtraction dif))
centers)
(if mtrans
(vla-TransformBy base mtrans))
(ax-translation base (trans center 1 0 t))
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 18.17. Main function C:CONNECTOR.
(defun coupling-data (/)
(initget 1)
(setq center (getpoint "\nSpecify coupling's center: "))
(initget (+ 1 2 4))
(setq dim-x (getdist center "\nSpecify coupling's length: ")
origin '(0.0 0.0 0.0)
r (/ dim-x 2.0))
(cond
((= (getvar "SOLIDHIST") 0)
(initget 1 "Yes No")
(if
(equal (getkword "\nRecord Solids history? [Yes/No]: ")
"Yes")
(setvar "SOLIDHIST" 1)))))
;;;Listing 18.18. Function that prompts for the coupling's data.
(defun ax-box (center dim-x dim-y dim-z / res)
(setq res (vl-catch-all-apply
'vla-AddBox
(list (current-space *aevl:drawing*)
(vlax-3d-point center)
dim-x
dim-y
dim-z)))
(cond
((vl-catch-all-error-p res)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res))))
(t
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History res :vlax-true))
res)))
;;;Listing 18.19. Function that creates a 3DSolid rectangular prism.
(defun rot-180-z (obj /)
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos pi) (- (sin pi)) 0.0 0.0)
(list (sin pi) (cos pi) 0.0 0.0)
(list 0.0 0.0 1.0 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 18.20. Function that rotates an object 180 degrees around the Z axis.
(defun C:COUPLING (/ mtrans origin center dim-x r base hole box1 box2)
(vla-StartUndoMark *aevl:drawing*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-ucs-matrix))))
(t (setq mtrans nil)))
(coupling-data)
(setq base (ax-cylinder (list r 0.0 0.0) r (* r 2))
hole (ax-cylinder (list r 0.0 0.0) (/ r 2.0) (* r 2))
box1 (ax-box
(list (- (* 0.5 r)) 0.0 0.0)
(* 3 r)
(* 2 r)
(* 2 r))
box2 (ax-box (list (- r) 0.0 0.0) (* 2 r) r (* r 2)))
(vla-Boolean base acUnion box1)
(vla-Boolean base acSubtraction box2)
(vla-Boolean base acSubtraction hole)
(setq base-copy (vla-Copy base))
(rot-90-x base-copy)
(rot-180-z base-copy)
(vla-Boolean base acIntersection base-copy)
(if mtrans
(vla-TransformBy base mtrans))
(ax-translation base (trans center 1 0 t))
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 18.21. Main function C:COUPLING.
(defun trimmer (trimming to-trim / tmp)
(setq tmp (if (>= (atoi (getvar "acadver")) 19)
(vl-catch-all-apply
'vla-CheckInterference
(list trimming
to-trim
:vlax-true
'SolidsInterfere))
(vl-catch-all-apply
'vla-CheckInterference
(list trimming to-trim :vlax-true))))
(cond
((vl-catch-all-error-p tmp)
(prompt (vl-catch-all-error-message tmp)))
((null tmp)
(prompt "\nThe selected solids do not interfere."))
(tmp
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History to-trim :vlax-true))
(vl-catch-all-apply
'vla-Boolean
(list to-trim acSubtraction tmp))))
(princ))
;;;Listing 18.22. Function that trims a Solid against another.
(defun C:SOL-TRIM (/ trimming trimmed to-trim *error*)
(vl-load-com)
(defun *error* (msg)
(vla-EndUndoMark *aevl:drawing*)
(command-s "_U")
(prompt msg))
(vla-StartUndoMark *aevl:drawing*)
(prompt "\Select trimming 3DSolid ")
(setq trimming (vlax-ename->vla-object
(ssname (ssget "_:S" '((0 . "3DSOLID"))) 0)))
(prompt "\Select 3DSolids to be trimmed ")
(setq trimmed (ssget '((0 . "3DSOLID")))
i 0)
(repeat (sslength trimmed)
(setq to-trim (vlax-ename->vla-object (ssname trimmed i)))
(trimmer trimming to-trim)
(setq i (1+ i)))
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;; Listing 18.23. Main function C:SOL-TRIM.
(defun separate (obj /)
(vl-cmdf "_solidedit"
"_body"
"_separate"
(vlax-vla-object->ename obj)
"_exit"
"_exit"))
;;;Listing 18.24. Function that separates composite 3DSolids.
(defun splitter (obj1 obj2 / interf tmp res)
(setq interf (if (>= (atoi (getvar "acadver")) 19)
(vl-catch-all-apply
'vla-CheckInterference
(list obj1 obj2 :vlax-true 'SolidsInterfere))
(vl-catch-all-apply
'vla-CheckInterference
(list obj1 obj2 :vlax-true))))
(cond
((vl-catch-all-error-p interf)
(prompt (vl-catch-all-error-message interf)))
(interf
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History interf :vlax-true))
(setq tmp (vla-Copy interf))
(setq res (vl-catch-all-apply
'vla-Boolean
(list obj1 acSubtraction tmp)))
(if (not (vl-catch-all-error-p res))
(separate obj1))
(setq tmp (vla-Copy interf))
(setq res (vl-catch-all-apply
'vla-Boolean
(list obj2 acSubtraction tmp)))
(if (not (vl-catch-all-error-p res))
(separate obj2))))
obj1)
;;;Listing 18.25. Function that makes new shapes out of the overlapping volumes.
(defun C:SOL-SPLIT (/ to-split base obj *error*)
(vl-load-com)
(defun *error* (msg)
(vla-EndUndoMark *aevl:drawing*)
(command-s "_U")
(prompt msg))
(vla-StartUndoMark *aevl:drawing*)
(prompt "\Select 3DSolids to split ")
(setq to-split (ssget '((0 . "3DSOLID")))
i 0
j 0)
(repeat (sslength to-split)
(setq base (vlax-ename->vla-object (ssname to-split i)))
(repeat (sslength to-split)
(setq obj (vlax-ename->vla-object (ssname to-split j)))
(if (not (equal base obj))
(setq base (splitter base obj)))
(setq j (1+ j)))
(setq i (1+ i)
j 0))
(ax-SWt)
(setvar "VSFACEOPACITY" 50)
(vla-EndUndoMark *aevl:drawing*))
;;; Listing 18.26. Main function C:SOL-SPLIT.
(defun ent-section (pt-lst planevector name topheight bottomheight /)
(entmake
(append
(list '(0 . "SECTIONOBJECT")
'(100 . "AcDbEntity")
'(100 . "AcDbSection")
(cons 1 name) ;Name
(cons 10 planevector) ;VerticalDirection
(cons 40 topheight) ;TopHeight
(cons 41 bottomheight) ;BottomHeight
(cons 92 (length pt-lst))) ;NumVertices
(mapcar '(lambda (pt) (cons 11 pt)) pt-lst))))
;;;Listing 18.27. Function that creates a SECTION using entmake.
(defun ax-section (pt-lst planevector / sect-obj i pt)
(setq sect-obj (vla-AddSection
(current-space *aevl:drawing*)
(vlax-3d-point (nth 0 pt-lst))
(vlax-3d-point (nth 1 pt-lst))
(vlax-3d-point planevector)))
(setq i 2)
(while (setq pt (nth i pt-lst))
(vla-AddVertex sect-obj i (vlax-3d-point pt))
(setq i (1+ i)))
sect-obj)
;;;Listing 18.28. Function that creates a SECTION using ActiveX methods.
(defun sect-geom (sect-obj model name / objs intbound-objs intfill-objs backg-objs
foreg-objs curvetang-objs)
(vla-GenerateSectionGeometry sect-obj model 'intbound-objs 'intfill-objs
'backg-objs 'foreg-objs 'curvetang-objs)
(setq objs (apply
'append
(mapcar
'(lambda (a)
(if (>= (vlax-safearray-get-u-bound a 1) 0)
(vlax-safearray->list a)))
(list intbound-objs intfill-objs backg-objs foreg-objs
curvetang-objs))))
(ax-add-group
name
(apply
'append
(mapcar
'(lambda (a)
(if (>= (vlax-safearray-get-u-bound a 1) 0)
(vlax-safearray->list a)))
(list intbound-objs intfill-objs backg-objs foreg-objs curvetang-objs)))))
;;;Listing 18.31. Function that creates the section geometry.
(defun add-layers (name spacer lyr-lst / lyr coll res)
(setq coll (vla-get-Layers *aevl:drawing*))
(foreach lyr lyr-lst
(setq lyr (strcat name spacer lyr))
(setq res (vl-catch-all-apply 'vla-Item (list coll lyr)))
(if (vl-catch-all-error-p res)
(vla-Add coll lyr))))
;;;Listing 18.30. Function that adds layers to the drawing
(defun sect-props (sect-obj size name topheight bottomheight viewdir / settings
sec-type-sett clr)
(vla-put-name sect name)
(vla-put-TopHeight sect topheight)
(vla-put-BottomHeight sect bottomheight)
(vla-put-ViewingDirection sect (vlax-3d-point viewdir))
(vla-put-TrueColor sect (vla-get-IndicatorFillColor sect))
(vla-put-Layer sect (strcat name "_Section"))
(vla-put-State2 sect-obj acSectionStatePlane) ;SectionState
(setq settings (vla-get-Settings sect-obj))
(vla-put-CurrentSectionType settings acSectionType2dSection) ;SectionType
(setq sec-type-sett (vla-GetSectionTypeSettings
settings
acSectionType2dSection)) ;SectionType settings
;;Layers-----------------------------------------------------
(vla-put-BackgroundLinesLayer ;Layers
sec-type-sett
(strcat name "_" "BackgroundLines"))
(vla-put-CurveTangencyLinesLayer
sec-type-sett
(strcat name "_" "CurveTangencyLines"))
(vla-put-ForegroundLinesLayer
sec-type-sett
(strcat name "_" "ForegroundLines"))
(vla-put-IntersectionBoundaryLayer
sec-type-sett
(strcat name "_" "IntersectionBoundary"))
(vla-put-IntersectionFillLayer
sec-type-sett
(strcat name "_" "IntersectionFill"))
;;Visibility----------------------------------------------
(vla-put-CurveTangencyLinesVisible ;Visibility
sec-type-sett
:vlax-false)
(vla-put-ForegroundLinesVisible sec-type-sett :vlax-false)
(vla-put-IntersectionFillVisible sec-type-sett :vlax-true)
(vla-put-ForegroundLinesLinetype sec-type-sett "byLayer") ;Linetypes
(vla-put-BackgroundLinesLinetype sec-type-sett "byLayer")
(vla-put-IntersectionFillLinetype sec-type-sett "byLayer")
(vla-put-IntersectionBoundaryLinetype sec-type-sett "byLayer")
(vla-put-BackgroundLinesHiddenLine sec-type-sett :vlax-true)
(vla-put-BackgroundLinesLineweight sec-type-sett acLnWt000) ;Lineweight
(vla-put-IntersectionFillLineweight sec-type-sett acLnWt000)
(vla-put-IntersectionBoundaryLineweight sec-type-sett acLnWt030)
(setq clr (vla-get-IntersectionBoundaryColor sec-type-sett))
(vla-put-ColorIndex clr acBylayer) ;Color
(vla-put-IntersectionBoundaryColor sec-type-sett clr)
(vla-put-IntersectionFillColor sec-type-sett clr)
(vla-put-ForegroundLinesColor sec-type-sett clr)
(vla-put-CurveTangencyLinesColor sec-type-sett clr)
(vla-put-BackgroundLinesColor sec-type-sett clr)
(vla-put-IntersectionFillHatchPatternType ;Hatch properties
sec-type-sett
acHatchPatternTypeUserDefined)
(vla-put-IntersectionFillHatchPatternName
sec-type-sett
"_U")
(vla-put-IntersectionFillHatchAngle sec-type-sett (/ pi 4))
(vla-put-IntersectionFillHatchSpacing
sec-type-sett
(/ size 60)))
;;;Listing 18.31. Section object properties.
(defun sect-data (/ minPoint maxPoint xmin ymin zmin xmax ymax zmax dx dy dz)
(initget "Top Front Side")
(if (not (setq opt (getkword "\nView [Top/Front/Side] : ")))
(setq opt "Top"))
(initget 1)
(setq name (getstring "\nName for section: "))
(prompt "\Select 3D Solid to be sectioned: ")
(while (not (setq obj (ssget "_:S" '((0 . "3DSOLID")))))
(prompt "\Select 3D Solid to be sectioned: "))
(setq obj (vlax-ename->vla-object (ssname obj 0)))
(vla-GetBoundingBox obj 'minPoint 'maxPoint)
(cond
((and minPoint maxPoint)
(setq minPoint (vlax-safearray->list minPoint)
maxPoint (vlax-safearray->list maxPoint)
xmin (nth 0 minPoint)
ymin (nth 1 minPoint)
zmin (nth 2 minPoint)
xmax (nth 0 maxPoint)
ymax (nth 1 maxPoint)
zmax (nth 2 maxPoint)
dx (- xmax xmin)
dy (- ymax ymin)
dz (- zmax zmin)
dmin (min dx dy dz))
(sect-options opt dy dz xmin ymin xmax ymax zmax))))
;;;Listing 18.32. Data entry function.
(defun sect-options (opt dy dz xmin ymin xmax ymax zmax /)
(cond
((= opt "Top")
(setq planeVector '(0 1 0)
viewdir '(0 0 1)
bottomheight (* dy 0.2)
topheight (+ dy bottomheight)
pt-lst (list
(list (- xmin bottomheight)
ymin
(/ (+ zmin zmax) 2.0))
(list (+ xmax bottomheight)
ymin
(/ (+ zmin zmax) 2.0)))))
((= opt "Front")
(setq planeVector '(0 0 1)
viewdir '(0 -1 0)
bottomheight (* dz 0.2)
topheight (+ dz bottomheight)
pt-lst (list
(list (- xmin bottomheight)
(/ (+ ymin ymax) 2.0)
zmin)
(list (+ xmax bottomheight)
(/ (+ ymin ymax) 2.0)
zmin))))
((= opt "Side")
(setq planeVector '(0 0 1)
viewdir '(-1 0 0)
bottomheight (* dz 0.2)
topheight (+ dz bottomheight)
pt-lst (list
(list (/ (+ xmin xmax) 2.0)
(- ymin bottomheight)
zmin)
(list (/ (+ xmin xmax) 2.0)
(+ ymax bottomheight)
zmin))))))
;;;Listing 18.33. Section options.
(defun C:SOL-SECT (/ *error* opt name obj sect planevector viewdir bottomheight
topheight pt-lst)
(defun *error* (msg)
(vla-EndUndoMark *aevl:drawing*)
(command-s "_U")
(prompt msg))
(vla-StartUndoMark *aevl:drawing*)
(sect-data)
(add-layers
name
"_"
'("Section" "BackgroundLines" "CurveTangencyLines" "ForegroundLines"
"IntersectionBoundary" "IntersectionFill"))
(setq sect (ax-section pt-lst planevector))
(sect-props sect dmin name topheight bottomheight viewdir)
(sect-geom sect obj name)
(vla-EndUndoMark *aevl:drawing*))
;;;Listing 18.34. Main function C:SOL-SECT.
;;; C:STRIM -----------------------------------------
;;; Updated version for C:SOL-TRIM which allows for
;;; selecting multiple trimming 3DSolids.
;;; This version operates in two nested repeat loops.
(defun C:STRIM (/ trimming trimmed to-trim *error*)
(vl-load-com)
(defun *error* (msg)
(vla-EndUndoMark *aevl:drawing*)
(vl-cmdf "_U")
(prompt msg))
(vla-StartUndoMark *aevl:drawing*)
(prompt "\Select trimming 3DSolids:")
(setq trimset (ssget '((0 . "3DSOLID"))))
(prompt "\Select 3DSolids to be trimmed:")
(setq trimmed (ssget '((0 . "3DSOLID")))
j 0)
(repeat (sslength trimset)
(setq i 0)
(setq trimming (vlax-ename->vla-object (ssname trimset j))
j (1+ j))
(repeat (sslength trimmed)
(setq to-trim (vlax-ename->vla-object (ssname trimmed i)))
(trimmer trimming to-trim)
(setq i (1+ i))))
(ax-SWt)
(vla-EndUndoMark *aevl:drawing*))
;;; C:STRIM -----------------------------------------
(defun ax-view-dir (sect zoom / vport)
(setq vport (vla-get-ActiveViewport *aevl:drawing*))
(vla-put-Direction vport (vla-get-ViewingDirection sect))
(vla-put-ActiveViewport *aevl:drawing* vport)
(if zoom
(vla-ZoomExtents *aevl:acad*))
(princ))
;;; Function that orients the view according to the section.
No comments:
Post a Comment