;;; (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 13. 3D Objects.
(defun ent-plin (pt-i pt-f norm /)
(entmake (list '(0 . "LWPOLYLINE") ;Entity type
'(100 . "AcDbEntity") ;Subclass
'(100 . "AcDbPolyline") ;Subclass
'(90 . 2) ;Number of vertices
(cons 10 pt-i) ;Coordinates for vertex 1
'(91 . 1) ;Vertex Id
(cons 10 pt-f) ;Coordinates for vertex 2
'(91 . 2) ;Vertex Id
(cons 210 norm)))) ;Normal vector
;;;Listing 13.1. Function that draws a polyline in the plane defined by the normal vector.
(defun ent-lin (pt-i pt-f norm /)
(entmake (list '(0 . "LINE") ;Tipo entidad
'(100 . "AcDbEntity") ;Subclass
'(100 . "AcDbLine") ;Subclass
(cons 10 pt-i) ;Vertex 1
(cons 11 pt-f) ;Vertex 2
(cons 210 norm)))) ;Normal vector
;;;Listing 13.2 Test function that creates a line specifying its normal vector.
(defun ax-trans (pt from-ucs to-ucs as-vector ocs-normal /
utility-object args res)
(vl-load-com)
(setq utility-object
(vla-get-Utility
(vla-get-ActiveDocument
(vlax-get-acad-object))))
(if as-vector
(setq as-vector :vlax-true)
(setq as-vector :vlax-false))
(setq args (list utility-object
(vlax-3d-point pt)
from-ucs
to-ucs
as-vector))
(if ocs-normal
(setq res
(vl-catch-all-apply
'vla-TranslateCoordinates
(append args
(list (vlax-3d-point ocs-normal)))))
(setq res
(vl-catch-all-apply
'vla-TranslateCoordinates
args)))
(if (vl-catch-all-error-p res)
(prompt (vl-catch-all-error-message res))
(vlax-safearray->list (vlax-variant-value res))))
;;;Listing 13.3. Replacement function for trans using ActiveX method TranslateCoordinates.
;;; Vector A to B
;;; Arguments: A, B, lists of three real numbers.
(defun vec (A B) (mapcar '- B A))
;;; Vector addition
;;; Arguments: v1, v2, lists of three real numbers.
(defun v+v (v1 v2) (mapcar '+ v1 v2))
;;; Scalar product (dot product)
;;; Arguments: v1, v2, lists of three real numbers.
(defun x-scalar (v1 v2)
(apply '+ (mapcar '* v1 v2)))
;;; Vector length (module)
;;; Argument: v, a list of three real numbers.
(defun m-vec (v)
(sqrt (apply '+ (mapcar '* v v))))
;;; Unit vector
;;; Argument: v, a list of three real numbers.
(defun v-unit (v / m)
(cond ((zerop (setq m (m-vec v))) nil)
(t (mapcar '(lambda (n) (/ n m)) v))))
;;; Cross product (vector product)
;;; Arguments: v1, v2, lists of three real numbers.
(defun vec-prod (v1 v2)
(list (- (* (cadr v1) (caddr v2))
(* (cadr v2) (caddr v1)))
(- (* (car v2) (caddr v1))
(* (car v1) (caddr v2)))
(- (* (car v1) (cadr v2))
(* (car v2) (cadr v1)))))
;;;Listing 13.4. Vector operations.
(defun ax-translation (obj vector)
(vla-TransformBy
obj
(vlax-tmatrix
(list (list 1.0 0.0 0.0 (nth 0 vector))
(list 0.0 1.0 0.0 (nth 1 vector))
(list 0.0 0.0 1.0 (nth 2 vector))
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 13.5. Translation function.
;;; Degrees to Radians
(defun dtr (g) (/ (* g pi) 180.0))
;;; Radians to Degrees
(defun rtd (r) (* (/ r pi) 180.0))
;;;Listing 13.6. Radian-Degree conversions.
(defun ax-rot-x (obj a)
(setq a (dtr a))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list 1.0 0.0 0.0 0.0)
(list 0.0 (cos a) (sin a) 0.0)
(list 0.0 (- (sin a)) (cos a) 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 13.7. Rotation about X.
(defun ax-rot-y (obj a)
(setq a (dtr a))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos a) 0.0 (sin a) 0.0)
(list 0.0 1.0 0.0 0.0)
(list (- (sin a)) 0.0 (cos a) 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 13.8. Rotation about Y.
(defun ax-rot-z (obj a)
(setq a (dtr a))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos a) (- (sin a)) 0.0 0.0)
(list (sin a) (cos a) 0.0 0.0)
(list 0.0 0.0 1.0 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listing 13.9. Rotación en torno a Z.
(defun ax-scale (obj vector / res)
(setq res
(vl-catch-all-apply
'vla-TransformBy
(list obj
(vlax-tmatrix
(list (list (nth 0 vector) 0.0 0.0 0.0)
(list 0.0 (nth 1 vector) 0.0 0.0)
(list 0.0 0.0 (nth 2 vector) 0.0)
(list 0.0 0.0 0.0 1.0))))))
(if (vl-catch-all-error-p res)
(prompt "This object can not be transformed!")))
;;;Listing 13.10. XYZ Scaling function.
(defun ax-shear-x (obj factor / res)
(setq res
(vl-catch-all-apply 'vla-TransformBy
(list obj
(vlax-tmatrix
(list (list 1.0 factor 0.0 0.0)
(list 0.0 1.0 0.0 0.0)
(list 0.0 0.0 1.0 0.0)
(list 0.0 0.0 0.0 1.0))))))
(if (vl-catch-all-error-p res)
(prompt "This object can not be transformed!")))
;;;Listing 13.11. Shear along X.
(defun ax-shear-y (obj factor / res)
(setq res
(vl-catch-all-apply 'vla-TransformBy
(list obj
(vlax-tmatrix
(list (list 1.0 0.0 0.0 0.0)
(list factor 1.0 0.0 0.0)
(list 0.0 0.0 1.0 0.0)
(list 0.0 0.0 0.0 1.0))))))
(if (vl-catch-all-error-p res)
(prompt "This object can not be transformed!")))
;;;Listing 13.12. Shear along Y.
(defun ax-shear-z (obj factor / res)
(setq res
(vl-catch-all-apply 'vla-TransformBy
(list
obj
(vlax-tmatrix
(list (list 1.0 0.0 0.0 0.0)
(list 0.0 1.0 0.0 0.0)
(list factor factor 1.0 0.0)
(list 0.0 0.0 0.0 1.0))))))
(if (vl-catch-all-error-p res)
(prompt "This object can not be transformed!")))
;;;Listing 13.13. Shear along Z.
(defun C:TRANSFORM (/ obj base factor-x factor-y factor-z)
(if (setq obj
(vlax-ename->vla-object
(car
(entsel "\nSelect object to transform: "))))
(progn (setq base (getpoint "\nBase point: "))
(initget (+ 1 2))
(setq factor-x (getreal "\nScale factor X: "))
(initget (+ 1 2))
(setq factor-y (getreal "\nScale factor Y: "))
(initget (+ 1 2))
(setq factor-z (getreal "\nScale factor Z: "))
(ax-translation obj (mapcar '- base))
(ax-scale obj (list factor-x factor-y factor-z))
(ax-translation obj base))
(prompt "\nNo object selected.")))
;;;Listing 13.14. Command for XYZ scaling.
(defun ax-ucs (name origin dirx diry / tmp)
(setq tmp
(vla-Add (vla-get-UserCoordinateSystems *aevl:drawing*)
(vlax-3d-point '(0 0 0))
(vlax-3d-point dirx)
(vlax-3d-point diry)
name))
(vla-put-Origin tmp (vlax-3d-point origin))
tmp)
;;;Listing 13.15. Function that adds a new UCS to the current document.
(defun ax-ucs-matrix (/ name ucs-num new-ucs)
(setq name (getvar "UCSNAME"))
(cond
((or (equal name "")
(and (vl-string-search "*" name 0)
(vl-string-search "*" name (1- (strlen name)))))
(setq ucs-num (vla-get-Count
(vla-get-UserCoordinateSystems
*aevl:drawing*))
name (strcat "SCP_" (itoa ucs-num)))
(setq new-ucs (ax-ucs name
(getvar "UCSORG")
(getvar "UCSXDIR")
(getvar "UCSYDIR")))
(vla-put-ActiveUCS *aevl:drawing* new-ucs)
(list name (vla-GetUCSMatrix new-ucs)))
(t
(list (vla-get-Name (vla-get-ActiveUCS *aevl:drawing*))
(vla-GetUCSMatrix (vla-get-ActiveUCS *aevl:drawing*))))))
;;;Listing 13.16. Function that returns the current UCS transformation matrix.
(defun ax-view (direction zoom / vport)
(setq vport (vla-get-ActiveViewport *aevl:drawing*))
(vla-put-Direction vport (vlax-3d-point direction))
(vla-put-ActiveViewport *aevl:drawing* vport)
(vlax-release-object vport)
(if zoom
(vla-ZoomExtents *aevl:acad*))
(princ))
;;;Listing 13.17. Function that sets the view direction and visual style.
(defun var-vis ()
(if (= (getvar "BLOCKEDITOR") 0)
(progn (setvar "VSFACESTYLE" 2)
(setvar "VSMONOCOLOR" "RGB:211,76,3")
(setvar "VSFACECOLORMODE" 1)
(setvar "VSSHADOWS" 0)
(setvar "VSHALOGAP" 0)
(setvar "VSSILHEDGES" 0)
(setvar "VSINTERSECTIONEDGES" 0)
(setvar "VSEDGEJITTER" 0)
(setvar "VSFACEOPACITY" 100)
(setvar "VSEDGES" 1)
(setvar "VSEDGECOLOR" "ByEntity")
(setvar "VSISOONTOP" 0)
(setvar "VSOBSCUREDEDGES" 0)
(setvar "VSOCCLUDEDEDGES" 0)
(setvar "VSINTERSECTIONEDGES" 0)
(setvar "PERSPECTIVE" 1))))
;;;Listing 13.18. Function that sets a custom visual style.
(defun ax-top ()
(ax-view '(0 0 1) t)
(var-vis))
(defun ax-right ()
(ax-view '(1 0 0) t)
(var-vis))
(defun ax-front ()
(ax-view '(0 -1 0) t)
(var-vis))
(defun ax-NEt ()
(ax-view '(1 1 1) t)
(var-vis))
(defun ax-NWt ()
(ax-view '(-1 1 1) t)
(var-vis))
(defun ax-SWt ()
(ax-view '(-1 -1 1) t)
(var-vis))
(defun ax-SEt ()
(ax-view '(1 -1 1) t)
(var-vis))
(defun ax-bottom ()
(ax-view '(0 0 -1) t)
(var-vis))
(defun ax-left ()
(ax-view '(-1 0 0) t)
(var-vis))
(defun ax-back ()
(ax-view '(0 1 0) t)
(var-vis))
(defun ax-NEb ()
(ax-view '(1 1 -1) t)
(var-vis))
(defun ax-NWb ()
(ax-view '(-1 1 -1) t)
(var-vis))
(defun ax-SWb ()
(ax-view '(-1 -1 -1) t)
(var-vis))
(defun ax-SEb ()
(ax-view '(1 -1 -1) t)
(var-vis))
;;;Listing 13.19. Functions that set the 3D isometric view.
No comments:
Post a Comment