Author Topic: --={ Challenge }=-- code for align3d command...  (Read 2445 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
--={ Challenge }=-- code for align3d command...
« on: February 14, 2023, 11:40:26 AM »
I think I haven't missed all of this kind of topics, but this cobbled me since ever I worked in 3D...
If I find some time I'd like to participate, but I doubt, since I don't fully know how to manipulate in 3D in various ways...
This topic is also for some also different transformations - from one 3D orientation to some different also in 3D...
Everything is included with type of Auto Lisp/Visual Lisp functions and here I can say that (transformby) should be your guide...

I suppose every input to be thought as useful for working in 3D, but also 2D could be also accepted if it has some beneficial reasons...

So, let's start...
Good luck and happy coding...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #1 on: February 14, 2023, 11:43:01 AM »
Just saw it...
Here is starting topic to examine :
https://www.theswamp.org/index.php?topic=42767.msg479621#msg479621

(you have to be logged...)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #2 on: February 14, 2023, 12:11:39 PM »
For those that can't access previous link, here is full code from @Highflybird...
But don't stop thinking - how can it be faster, or better...

Code - Auto/Visual Lisp: [Select]
  1. ;;;-----------------------------------------------------------;;
  2. ;;; To simulate the command: "align"                          ;;
  3. ;;; Command:Align-3d                                           ;;
  4. ;;; Use in some cases: command can't be applied or you don't  ;;
  5. ;;; want to use them; or improve the efficiency,etc.and here  ;;
  6. ;;; are some useful functions,e.g. "Mat:Get3PMatrix";Or even  ;;
  7. ;;; you can customize "align" command.                        ;;
  8. ;;; Author: Highflybird, Date:2012-8-6.                       ;;
  9. ;;; All copyrights reserved.                                  ;;
  10. ;;;-----------------------------------------------------------;;
  11. (defun C:Align-3d ( / sel sP1 sP2 sP3 dP1 dP2 dP3 sclp scl
  12.                      mat0 mat1 mat2 mat i ent obj app doc
  13.                      Mat:norm Mat:vxs Mat:unit Mat:v*v Mat:v^v Mat:trp Mat:mxv Mat:mxm Mat:Rotate90 Mat:Get3PMatrix )
  14.  
  15.   ;;;-----------------------------------------------------------;;
  16.   ;;; Vector Norm - Lee Mac                                     ;;
  17.   ;;; Args: v - vector in R^n                                   ;;
  18.   ;;;-----------------------------------------------------------;;
  19.   (defun Mat:norm ( v )
  20.     (sqrt (apply '+ (mapcar '* v v)))
  21.   )
  22.  
  23.   ;;;-----------------------------------------------------------;;
  24.   ;;; Vector x Scalar - Lee Mac                                 ;;
  25.   ;;; Args: v - vector in R^n, s - real scalar                  ;;
  26.   ;;;-----------------------------------------------------------;;
  27.   (defun Mat:vxs ( v s )
  28.     (mapcar (function (lambda ( n ) (* n s))) v)
  29.   )
  30.  
  31.   ;;;-----------------------------------------------------------;;
  32.   ;;; Unit Vector - Lee Mac                                     ;;
  33.   ;;; Args: v - vector in R^n                                   ;;
  34.   ;;;-----------------------------------------------------------;;
  35.   (defun Mat:unit ( v )
  36.     ( (lambda ( n )
  37.         (if (equal 0.0 n 1e-14)
  38.           nil
  39.           (Mat:vxs v (/ 1.0 n))
  40.         )
  41.       )
  42.       (Mat:norm v)
  43.     )
  44.   )
  45.  
  46.   ;;;-----------------------------------------------------------;;
  47.   ;;; Mat:v*v Returns the dot product of 2 vectors              ;;
  48.   ;;;-----------------------------------------------------------;;
  49.   (defun Mat:v*v (v1 v2)
  50.     (apply '+ (mapcar '* v1 v2))
  51.   )
  52.  
  53.   ;;;-----------------------------------------------------------;;
  54.   ;;; Vector Cross Product - Lee Mac                            ;;
  55.   ;;; Args: u,v - vectors in R^3                                ;;
  56.   ;;;-----------------------------------------------------------;;
  57.   (defun Mat:v^v ( u v )
  58.     (list
  59.       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
  60.       (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))
  61.       (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
  62.     )
  63.   )
  64.  
  65.   ;;;-----------------------------------------------------------;;
  66.   ;;; Mat:trp Transpose a matrix -Doug Wilson-                  ;;
  67.   ;;;-----------------------------------------------------------;;
  68.   (defun Mat:trp (m)
  69.     (apply 'mapcar (cons 'list m))
  70.   )
  71.  
  72.   ;;;-----------------------------------------------------------;;
  73.   ;;; Matrix x Vector - Vladimir Nesterovsky                    ;;
  74.   ;;; Args: m - nxn matrix, v - vector in R^n                   ;;
  75.   ;;;-----------------------------------------------------------;;
  76.   (defun Mat:mxv (m v)
  77.     (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
  78.   )
  79.  
  80.   ;;;-----------------------------------------------------------;;
  81.   ;;; Mat:mxm Multiply two matrices -Vladimir Nesterovsky-      ;;
  82.   ;;;-----------------------------------------------------------;;
  83.   (defun Mat:mxm (m q)
  84.     (mapcar (function (lambda (r) (Mat:mxv (Mat:trp q) r))) m)
  85.   )
  86.  
  87.   ;;;-----------------------------------------------------------;;
  88.   ;;; Mat:Rotate90 Rotate a point 90 degree by a basepoint      ;;
  89.   ;;;-----------------------------------------------------------;;
  90.   (defun Mat:Rotate90 (Pt BasePt / a)
  91.     (setq a (+ (/ pi 2) (angle BasePt Pt)))
  92.     (polar BasePt a (distance pt basePt))
  93.   )
  94.  
  95.   ;;;-----------------------------------------------------------;;
  96.   ;;; Mat:Get3PMatrix  -Highflybird-                            ;;
  97.   ;;;-----------------------------------------------------------;;
  98.   (defun Mat:Get3PMatrix (p1 p2 p3 / v1 v2 v3 mat org)
  99.     (defun AppendMatrix (mat org)
  100.       (append
  101.         (mapcar 'append mat (mapcar 'list org))
  102.         '((0. 0. 0. 1.))
  103.       )
  104.     )
  105.  
  106.     (setq v1 (Mat:unit (mapcar '- p2 p1)))
  107.     (setq v2 (Mat:unit (mapcar '- p3 p1)))
  108.     (setq v3 (Mat:unit (Mat:v^v v1 v2)))
  109.     (setq v2 (Mat:unit (Mat:v^v v3 v1)))
  110.     (setq mat (list v1 v2 v3))
  111.     (setq org (mapcar '- (Mat:mxv mat p1)))
  112.     (list
  113.       (AppendMatrix mat org)              ;this->wcs transformation matrix
  114.       (AppendMatrix (Mat:trp mat) p1)     ;wcs->this transformation matrix
  115.     )
  116.   )
  117.  
  118.   ;;input
  119.   (setq sel (ssget "_:L"))
  120.   (initget 9)
  121.   (setq sP1 (getpoint "\nSpecify first source point:"))
  122.   (initget 9)
  123.   (setq dP1 (getpoint "\nSpecify first destination point:"))
  124.   (initget 9)
  125.   (setq sP2 (getpoint "\nSpecify second source point:"))
  126.   (initget 9)
  127.   (setq dP2 (getpoint "\nSpecify second destination point:"))
  128.   (initget 8)
  129.   (setq sP3 (getpoint "\nSpecify third source point or <continue>:"))
  130.   (initget 9)
  131.   (if (null sP3)
  132.     (setq sP3 (Mat:Rotate90 sP2 sP1)
  133.           dP3 (Mat:Rotate90 dP2 dP1)
  134.     )
  135.     (setq dP3 (getpoint "\nSpecify third destination point:"))
  136.   )
  137.   (foreach x '(sP1 sP2 sP3 dP1 dP2 dP3)
  138.     (set x (trans (eval x) 1 0))
  139.   )
  140.   (initget "Yes No")
  141.   (setq sclp (getkword "\nScale objects based on alignment points? [Yes/No] <N>:"))
  142.  
  143.   ;;Get the transformation matrix
  144.   (setq mat1 (Mat:Get3PMatrix sP1 sP2 sP3))
  145.   (setq mat2 (Mat:Get3PMatrix dP1 dP2 dP3))
  146.   (if (= "Yes" sclp)
  147.     (setq scl (/ (distance dP1 dP2) (distance sP2 sP1))
  148.           mat0 (list (list scl 0 0 0)(list 0 scl 0 0) (list 0 0 scl 0) '(0 0 0 1))
  149.           mat (Mat:mxm (cadr mat2) (Mat:mxm mat0 (car mat1)))
  150.     )  
  151.     (setq mat (Mat:mxm (cadr mat2) (car mat1)))
  152.   )
  153.  
  154.   ;;Apply the transformation.
  155.   (setq i 0)
  156.   (if sel
  157.     (repeat (sslength sel)
  158.       (setq ent (ssname sel i))
  159.       (setq obj (vlax-ename->vla-object ent))
  160.       (vla-transformby obj (vlax-tmatrix mat))
  161.       (setq i (1+ i))
  162.     )
  163.   )
  164.   (princ)
  165. )
  166.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #3 on: February 14, 2023, 01:57:55 PM »
I suppose maybe something like this...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:align-3d-MR ( / *error* app doc groupbynum Mat:trp Mat:mxv Mat:mxm invm imat ch osm en ss bp dp dobj vecs i ent obj mat1 mat2 )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if osm
  6.       (setvar (quote osmode) osm)
  7.     )
  8.     (if m
  9.       (prompt m)
  10.     )
  11.     (princ)
  12.   )
  13.  
  14.   (defun groupbynum ( lst n / sub lll )
  15.  
  16.     (defun sub ( m n / ll q )
  17.       (cond
  18.         ( (and m (< (length m) n))
  19.           (repeat (- n (length m))
  20.             (setq m (append m (list nil)))
  21.           )
  22.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  23.           (setq lll (cons ll lll))
  24.           (setq q nil)
  25.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  26.         )
  27.         ( m
  28.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  29.           (setq lll (cons ll lll))
  30.           (setq q nil)
  31.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  32.         )
  33.         ( t
  34.           (reverse lll)
  35.         )
  36.       )
  37.     )
  38.  
  39.     (sub lst n)
  40.   )
  41.  
  42.   ;;;-----------------------------------------------------------;;
  43.   ;;; Mat:trp Transpose a matrix -Doug Wilson-                  ;;
  44.   ;;;-----------------------------------------------------------;;
  45.   (defun Mat:trp (m)
  46.     (apply 'mapcar (cons 'list m))
  47.   )
  48.  
  49.   ;;;-----------------------------------------------------------;;
  50.   ;;; Matrix x Vector - Vladimir Nesterovsky                    ;;
  51.   ;;; Args: m - nxn matrix, v - vector in R^n                   ;;
  52.   ;;;-----------------------------------------------------------;;
  53.   (defun Mat:mxv (m v)
  54.     (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
  55.   )
  56.  
  57.   ;;;-----------------------------------------------------------;;
  58.   ;;; Mat:mxm Multiply two matrices -Vladimir Nesterovsky-      ;;
  59.   ;;;-----------------------------------------------------------;;
  60.   (defun Mat:mxm (m q)
  61.     (mapcar (function (lambda (r) (Mat:mxv (Mat:trp q) r))) m)
  62.   )
  63.  
  64.   ;; Matrix Inverse  -  gile & Lee Mac
  65.   ;; Uses Gauss-Jordan Elimination to return the inverse of a non-singular nxn matrix.
  66.   ;; Args: m - nxn matrix
  67.  
  68.   (defun invm ( m / c f p r )
  69.  
  70.     (defun f ( p m )
  71.       (mapcar (function (lambda ( x ) (mapcar (function (lambda ( a b ) (- a (* (car x) b)))) (cdr x) p))) m)
  72.     )
  73.  
  74.     (setq  m (mapcar (function append) m (imat (length m))))
  75.     (while m
  76.       (setq c (mapcar (function (lambda ( x ) (abs (car x)))) m))
  77.       (repeat (vl-position (apply 'max c) c)
  78.         (setq m (append (cdr m) (list (car m))))
  79.       )
  80.       (if (equal 0.0 (caar m) 1e-14)
  81.         (setq m nil
  82.               r nil
  83.         )
  84.         (setq p (mapcar (function (lambda ( x ) (/ (float x) (caar m)))) (cdar m))
  85.               m (f p (cdr m))
  86.               r (cons p (f p r))
  87.         )
  88.       )
  89.     )
  90.     (reverse r)
  91.   )
  92.  
  93.   ;; Identity Matrix  -  Lee Mac
  94.   ;; Args: n - matrix dimension
  95.  
  96.   (defun imat ( n / i j l m )
  97.     (repeat (setq i n)
  98.       (repeat (setq j n)
  99.         (setq l (cons (if (= i j) 1.0 0.0) l)
  100.               j (1- j)
  101.         )
  102.       )
  103.       (setq m (cons l m)
  104.             l nil
  105.             i (1- i)
  106.       )
  107.     )
  108.     m
  109.   )
  110.  
  111.   (setq osm (getvar (quote osmode)))
  112.   (initget "End Int Both Non")
  113.   (setq ch (getkword "\nSet OSMODE to [End / Int / Both / Non] <End> : "))
  114.   (cond
  115.     ( (not ch)
  116.       (setq ch "End")
  117.     )
  118.     ( (= ch "Both")
  119.       (setq ch "end,int")
  120.     )
  121.   )
  122.   (if command-s
  123.     (command-s "_.OSNAP" ch)
  124.     (vl-cmdf "_.OSNAP" ch)
  125.   )
  126.   (if
  127.     (and
  128.       (progn (prompt "\nPick destination 3DSOLID object of alignment...") t)
  129.       (setq en (ssname (ssget "_+.:E:S" (list (cons 0 "3DSOLID"))) 0))
  130.       (progn (prompt "\nSelect object(s) you want to align...") t)
  131.       (setq ss (ssget "_:L"))
  132.       (setq bp (getpoint "\nPick or specify base point : "))
  133.       (setq dp (getpoint bp "\nPick or specify destination point : "))
  134.     )
  135.     (progn
  136.       (setq dobj (vlax-ename->vla-object en))
  137.       (setq vecs (groupbynum vecs 3))
  138.       (setq mat1 (Mat:trp vecs))
  139.       (setq mat1 (append mat1 (list (list 0.0 0.0 0.0))))
  140.       (setq mat1 (mapcar (function (lambda ( x ) (if (equal x (list 0.0 0.0 0.0)) (append x (list 1.0)) (append x (list 0.0))))) mat1))
  141.       (repeat (setq i (sslength ss))
  142.         (setq ent (ssname ss (setq i (1- i))))
  143.         (setq obj (vlax-ename->vla-object ent))
  144.         (setq vecs (groupbynum vecs 3))
  145.         (setq mat2 (Mat:trp vecs))
  146.         (setq mat2 (append mat2 (list (list 0.0 0.0 0.0))))
  147.         (setq mat2 (mapcar (function (lambda ( x ) (if (equal x (list 0.0 0.0 0.0)) (append x (list 1.0)) (append x (list 0.0))))) mat2))
  148.         (vla-transformby obj (vlax-tmatrix (Mat:mxm mat1 (invm mat2))))
  149.         (vla-move obj (vlax-3d-point (Mat:mxv (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 0.0 0.0) x))) (vl-remove (last (Mat:mxm mat1 (invm mat2))) (Mat:mxm mat1 (invm mat2)))) (trans bp 1 0))) (vlax-3d-point (trans dp 1 0)))
  150.       )
  151.     )
  152.   )
  153.   (*error* nil)
  154. )
  155.  

HTH.
M.R.
« Last Edit: September 06, 2023, 12:06:49 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #4 on: February 15, 2023, 09:38:22 AM »
Here is my additional code for making minimal bounding box of scattered 3DSOLID entities in 3D space... Please ensure they are separated and really not to much complex... So, perhaps, you don't have object to align to, but bunch of 3DSOLID(s), then you must firstly apply this code and only then my previous one for 3d alignment...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:minbbox-3dsolids ( / *error* tttt invm imat trp mxv groupbynum wcs initvalueslst ucsf ti ss el vecs obj mat invermat ll ur bb )
  2.  
  3.   (defun *error* ( m )
  4.     (if wcs
  5.       (if ucsf
  6.         (while
  7.           (not
  8.             (and
  9.               (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
  10.               (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
  11.               (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
  12.             )
  13.           )
  14.           (exe (list "_.UCS" "_P"))
  15.         )
  16.       )
  17.     )
  18.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  19.       (if (not (exe (list "_.UNDO" "_E")))
  20.         (if doc
  21.           (vla-endundomark doc)
  22.         )
  23.       )
  24.     )
  25.     (if initvalueslst
  26.       (mapcar (function apply_cadr->car) initvalueslst)
  27.     )
  28.     (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
  29.       (setq fun nil)
  30.     )
  31.     (if doc
  32.       (vla-regen doc acactiveviewport)
  33.     )
  34.     (if m
  35.       (prompt m)
  36.     )
  37.     (princ)
  38.   )
  39.  
  40.   (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;
  41.  
  42.     (defun vl-load nil
  43.       (or cad
  44.           (setq cad (vlax-get-acad-object))
  45.           (progn
  46.             (vl-load-com)
  47.             (setq cad (vlax-get-acad-object))
  48.           )
  49.         )
  50.       )
  51.       (or doc (setq doc (vla-get-activedocument cad)))
  52.       (or alo (setq alo (vla-get-activelayout doc)))
  53.       (or spc (setq spc (vla-get-block alo)))
  54.     )
  55.  
  56.     ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  57.     (or (and cad doc alo spc) (vl-load))
  58.  
  59.     (defun exe ( tokenslist )
  60.       ( (lambda ( tokenslist / ctch )
  61.           (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
  62.             (progn
  63.               (cmderr tokenslist)
  64.               (catch_cont ctch)
  65.             )
  66.             (progn
  67.               (while (< 0 (getvar (quote cmdactive)))
  68.                 (vl-cmdf "")
  69.               )
  70.               t
  71.             )
  72.           )
  73.         )
  74.         tokenslist
  75.       )
  76.     )
  77.  
  78.     (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
  79.       (if command-s
  80.         (if flag
  81.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
  82.             flag
  83.             ctch
  84.           )
  85.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
  86.             ctch
  87.           )
  88.         )
  89.         (if flag
  90.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
  91.             flag
  92.             ctch
  93.           )
  94.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
  95.             ctch
  96.           )
  97.         )
  98.       )
  99.     )
  100.  
  101.     (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
  102.       (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
  103.     )
  104.  
  105.     (defun catch_cont ( ctch / gr )
  106.       (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
  107.       (while
  108.         (and
  109.           (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
  110.           (setq gr (grread))
  111.           (/= (car gr) 3)
  112.           (not (equal gr (list 2 13)))
  113.         )
  114.       )
  115.       (if (vl-catch-all-error-p ctch)
  116.         ctch
  117.       )
  118.     )
  119.  
  120.     (defun apply_cadr->car ( sysvarvaluepair / ctch )
  121.       (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
  122.       (if (vl-catch-all-error-p ctch)
  123.         (progn
  124.           (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
  125.           (catch_cont ctch)
  126.         )
  127.       )
  128.     )
  129.  
  130.     (defun ftoa ( n / m a s b )
  131.       (if (numberp n)
  132.         (progn
  133.           (setq m (fix ((if (< n 0) - +) n 1e-8)))
  134.           (setq a (abs (- n m)))
  135.           (setq m (itoa m))
  136.           (setq s "")
  137.           (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
  138.             (setq s (strcat s (itoa b)))
  139.             (setq a (- (* a 10.0) b))
  140.           )
  141.           (if (= (type n) (quote int))
  142.             m
  143.             (if (= s "")
  144.               m
  145.               (if (and (= m "0") (< n 0))
  146.                 (strcat "-" m "." s)
  147.                 (strcat m "." s)
  148.               )
  149.             )
  150.           )
  151.         )
  152.       )
  153.     )
  154.  
  155.     (setq sysvarpreset
  156.       (list
  157.         (list (quote cmdecho) 0)
  158.         (list (quote 3dosmode) 0)
  159.         (list (quote osmode) 0)
  160.         (list (quote unitmode) 0)
  161.         (list (quote cmddia) 0)
  162.         (list (quote ucsvp) 0)
  163.         (list (quote ucsortho) 0)
  164.         (list (quote projmode) 0)
  165.         (list (quote orbitautotarget) 0)
  166.         (list (quote insunits) 0)
  167.         (list (quote hpseparate) 0)
  168.         (list (quote hpgaptol) 0)
  169.         (list (quote halogap) 0)
  170.         (list (quote edgemode) 0)
  171.         (list (quote pickdrag) 0)
  172.         (list (quote qtextmode) 0)
  173.         (list (quote dragsnap) 0)
  174.         (list (quote angdir) 0)
  175.         (list (quote aunits) 0)
  176.         (list (quote limcheck) 0)
  177.         (list (quote gridmode) 0)
  178.         (list (quote nomutt) 0)
  179.         (list (quote apbox) 0)
  180.         (list (quote attdia) 0)
  181.         (list (quote blipmode) 0)
  182.         (list (quote copymode) 0)
  183.         (list (quote circlerad) 0.0)
  184.         (list (quote filletrad) 0.0)
  185.         (list (quote filedia) 1)
  186.         (list (quote autosnap) 1)
  187.         (list (quote objectisolationmode) 1)
  188.         (list (quote highlight) 1)
  189.         (list (quote lispinit) 1)
  190.         (list (quote layerpmode) 1)
  191.         (list (quote fillmode) 1)
  192.         (list (quote dragmodeinterrupt) 1)
  193.         (list (quote dispsilh) 1)
  194.         (list (quote fielddisplay) 1)
  195.         (list (quote deletetool) 1)
  196.         (list (quote delobj) 1)
  197.         (list (quote dblclkedit) 1)
  198.         (list (quote attreq) 1)
  199.         (list (quote explmode) 1)
  200.         (list (quote frameselection) 1)
  201.         (list (quote ltgapselection) 1)
  202.         (list (quote pickfirst) 1)
  203.         (list (quote plinegen) 1)
  204.         (list (quote plinetype) 1)
  205.         (list (quote peditaccept) 1)
  206.         (list (quote solidcheck) 1)
  207.         (list (quote visretain) 1)
  208.         (list (quote regenmode) 1)
  209.         (list (quote celtscale) 1.0)
  210.         (list (quote ltscale) 1.0)
  211.         (list (quote osnapcoord) 2)
  212.         (list (quote grips) 2)
  213.         (list (quote dragmode) 2)
  214.         (list (quote lunits) 2)
  215.         (list (quote pickstyle) 3)
  216.         (list (quote navvcubedisplay) 3)
  217.         (list (quote pickauto) 3)
  218.         (list (quote draworderctl) 3)
  219.         (list (quote expert) 5)
  220.         (list (quote auprec) 6)
  221.         (list (quote luprec) 6)
  222.         (list (quote pickbox) 6)
  223.         (list (quote aperture) 6)
  224.         (list (quote osoptions) 7)
  225.         (list (quote dimzin) 8)
  226.         (list (quote pdmode) 35)
  227.         (list (quote pdsize) -1.5)
  228.         (list (quote celweight) -1)
  229.         (list (quote cecolor) "BYLAYER")
  230.         (list (quote celtype) "ByLayer")
  231.         (list (quote clayer) "0")
  232.       )
  233.     )
  234.     (setq sysvarlst (mapcar (function car) sysvarpreset))
  235.     (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  236.     (setq sysvarvals
  237.       (vl-remove nil
  238.         (mapcar
  239.           (function (lambda ( x )
  240.             (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
  241.           ))
  242.           sysvarlst
  243.         )
  244.       )
  245.     )
  246.     (setq sysvarlst
  247.       (vl-remove-if-not
  248.         (function (lambda ( x )
  249.           (getvar x)
  250.         ))
  251.         sysvarlst
  252.       )
  253.     )
  254.     (setq initvalueslst
  255.       (apply (function mapcar)
  256.         (cons (function list)
  257.           (list
  258.             sysvarlst
  259.             (mapcar (function getvar) sysvarlst)
  260.           )
  261.         )
  262.       )
  263.     )
  264.       (cons (function setvar)
  265.         (list
  266.           sysvarlst
  267.           sysvarvals
  268.         )
  269.       )
  270.     )
  271.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  272.       (if (not (exe (list "_.UNDO" "_E")))
  273.         (if doc
  274.           (vla-endundomark doc)
  275.         )
  276.       )
  277.     )
  278.     (if (not (exe (list "_.UNDO" "_M")))
  279.       (if doc
  280.         (vla-startundomark doc)
  281.       )
  282.     )
  283.     (if wcs
  284.       (if (= 0 (getvar (quote worlducs)))
  285.         (progn
  286.           (setq ucsf
  287.             (list
  288.               (getvar (quote ucsxdir))
  289.               (getvar (quote ucsydir))
  290.               (trans (list 0.0 0.0 1.0) 1 0 t)
  291.             )
  292.           )
  293.           (exe (list "_.UCS" "_W"))
  294.         )
  295.       )
  296.     )
  297.     wcs
  298.   )
  299.  
  300.   ;; Matrix Inverse  -  gile & Lee Mac
  301.   ;; Uses Gauss-Jordan Elimination to return the inverse of a non-singular nxn matrix.
  302.   ;; Args: m - nxn matrix
  303.  
  304.   (defun invm ( m / c f p r )
  305.  
  306.     (defun f ( p m )
  307.       (mapcar (function (lambda ( x ) (mapcar (function (lambda ( a b ) (- a (* (car x) b)))) (cdr x) p))) m)
  308.     )
  309.  
  310.     (setq  m (mapcar (function append) m (imat (length m))))
  311.     (while m
  312.       (setq c (mapcar (function (lambda ( x ) (abs (car x)))) m))
  313.       (repeat (vl-position (apply 'max c) c)
  314.         (setq m (append (cdr m) (list (car m))))
  315.       )
  316.       (if (equal 0.0 (caar m) 1e-14)
  317.         (setq m nil
  318.               r nil
  319.         )
  320.         (setq p (mapcar (function (lambda ( x ) (/ (float x) (caar m)))) (cdar m))
  321.               m (f p (cdr m))
  322.               r (cons p (f p r))
  323.         )
  324.       )
  325.     )
  326.     (reverse r)
  327.   )
  328.  
  329.   ;; Identity Matrix  -  Lee Mac
  330.   ;; Args: n - matrix dimension
  331.  
  332.   (defun imat ( n / i j l m )
  333.     (repeat (setq i n)
  334.       (repeat (setq j n)
  335.         (setq l (cons (if (= i j) 1.0 0.0) l)
  336.               j (1- j)
  337.         )
  338.       )
  339.       (setq m (cons l m)
  340.             l nil
  341.             i (1- i)
  342.       )
  343.     )
  344.     m
  345.   )
  346.  
  347.   ;;;-----------------------------------------------------------;;
  348.   ;;; trp Transpose a matrix -Doug Wilson-                      ;;
  349.   ;;;-----------------------------------------------------------;;
  350.   (defun trp ( m )
  351.   )
  352.  
  353.   ;;;-----------------------------------------------------------;;
  354.   ;;; Matrix x Vector - Vladimir Nesterovsky                    ;;
  355.   ;;; Args: m - nxn matrix, v - vector in R^n                   ;;
  356.   ;;;-----------------------------------------------------------;;
  357.   (defun mxv ( m v )
  358.     (mapcar (function (lambda ( r ) (apply (function +) (mapcar (function *) r v)))) m)
  359.   )
  360.  
  361.   (defun groupbynum ( lst n / sub lll )
  362.  
  363.     (defun sub ( m n / ll q )
  364.       (cond
  365.         ( (and m (< (length m) n))
  366.           (repeat (- n (length m))
  367.             (setq m (append m (list nil)))
  368.           )
  369.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  370.           (setq lll (cons ll lll))
  371.           (setq q nil)
  372.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  373.         )
  374.         ( m
  375.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  376.           (setq lll (cons ll lll))
  377.           (setq q nil)
  378.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  379.         )
  380.         ( t
  381.           (reverse lll)
  382.         )
  383.       )
  384.     )
  385.  
  386.     (sub lst n)
  387.   )
  388.  
  389.   (setq wcs (tttt t)) ;;; starting "library" template sub function - initialization ;;;
  390.   (prompt "\nSelect 3DSOLID entities to make minbbox 3DSOLID cube...")
  391.   (if (setq ss (ssget (list (cons 0 "3DSOLID"))))
  392.     (progn
  393.       (setq ti (car (_vl-times)))
  394.       (exe (list "_.UNDO" "_G"))
  395.       (setq el (entlast))
  396.       (exe (list "_.UNION" ss ""))
  397.       (if (not (eq el (entlast)))
  398.         (setq vecs (safearray-value (variant-value (vla-get-principaldirections (setq obj (vlax-ename->vla-object (setq el (entlast))))))))
  399.         (if
  400.           (and
  401.             (= (sslength ss) 1)
  402.             (setq el (ssname ss 0))
  403.           )
  404.           (setq vecs (safearray-value (variant-value (vla-get-principaldirections (setq obj (vlax-ename->vla-object el))))))
  405.         )
  406.       )
  407.       (setq vecs (groupbynum vecs 3))
  408.       (setq mat (trp vecs))
  409.       (setq mat (append mat (list (list 0.0 0.0 0.0))))
  410.       (setq mat (mapcar (function (lambda ( x ) (if (equal x (list 0.0 0.0 0.0)) (append x (list 1.0)) (append x (list 0.0))))) mat))
  411.       (setq invermat (invm mat))
  412.       (vla-transformby obj (vlax-tmatrix invermat))
  413.       (vla-getboundingbox obj (quote ll) (quote ur))
  414.       (mapcar (function set) (list (quote ll) (quote ur)) (mapcar (function safearray-value) (list ll ur)))
  415.       (exe (list "_.BOX" "_non" ll "_non" (list (car ur) (cadr ur) (caddr ll)) (- (caddr ur) (caddr ll))))
  416.       (setq bb (entlast))
  417.       (vla-transformby (vlax-ename->vla-object bb) (vlax-tmatrix mat))
  418.       (exe (list "_.COPYBASE" "_non" (list 0.0 0.0 0.0) bb ""))
  419.       (exe (list "_.UNDO" "_B"))
  420.       (exe (list "_.PASTECLIP" "_non" (list 0.0 0.0 0.0)))
  421.       (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
  422.       (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  423.     )
  424.   )
  425.   (*error* nil)
  426. )
  427.  

HTH.
M.R.
« Last Edit: February 16, 2023, 01:38:04 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #5 on: February 15, 2023, 01:17:53 PM »
Here is the one if you plan to cut some 3DSOLID with UCS aligned with its principal directions... For cutting - SLICE command you should be able to use : YZ, ZX or XY planes of aligned UCS...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:ucs-align-3d-3dsolid ( / *error* tttt groupbynum wcs initvalueslst ucsf ti ss el obj vecs cent bp )
  2.  
  3.   (defun *error* ( m )
  4.     (if wcs
  5.       (if ucsf
  6.         (while
  7.           (not
  8.             (and
  9.               (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
  10.               (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
  11.               (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
  12.             )
  13.           )
  14.           (exe (list "_.UCS" "_P"))
  15.         )
  16.       )
  17.     )
  18.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  19.       (if (not (exe (list "_.UNDO" "_E")))
  20.         (if doc
  21.           (vla-endundomark doc)
  22.         )
  23.       )
  24.     )
  25.     (if initvalueslst
  26.       (mapcar (function apply_cadr->car) initvalueslst)
  27.     )
  28.     (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
  29.       (setq fun nil)
  30.     )
  31.     (if doc
  32.       (vla-regen doc acactiveviewport)
  33.     )
  34.     (if m
  35.       (prompt m)
  36.     )
  37.     (princ)
  38.   )
  39.  
  40.   (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;
  41.  
  42.     (defun vl-load nil
  43.       (or cad
  44.           (setq cad (vlax-get-acad-object))
  45.           (progn
  46.             (vl-load-com)
  47.             (setq cad (vlax-get-acad-object))
  48.           )
  49.         )
  50.       )
  51.       (or doc (setq doc (vla-get-activedocument cad)))
  52.       (or alo (setq alo (vla-get-activelayout doc)))
  53.       (or spc (setq spc (vla-get-block alo)))
  54.     )
  55.  
  56.     ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  57.     (or (and cad doc alo spc) (vl-load))
  58.  
  59.     (defun exe ( tokenslist )
  60.       ( (lambda ( tokenslist / ctch )
  61.           (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
  62.             (progn
  63.               (cmderr tokenslist)
  64.               (catch_cont ctch)
  65.             )
  66.             (progn
  67.               (while (< 0 (getvar (quote cmdactive)))
  68.                 (vl-cmdf "")
  69.               )
  70.               t
  71.             )
  72.           )
  73.         )
  74.         tokenslist
  75.       )
  76.     )
  77.  
  78.     (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
  79.       (if command-s
  80.         (if flag
  81.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
  82.             flag
  83.             ctch
  84.           )
  85.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
  86.             ctch
  87.           )
  88.         )
  89.         (if flag
  90.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
  91.             flag
  92.             ctch
  93.           )
  94.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
  95.             ctch
  96.           )
  97.         )
  98.       )
  99.     )
  100.  
  101.     (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
  102.       (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
  103.     )
  104.  
  105.     (defun catch_cont ( ctch / gr )
  106.       (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
  107.       (while
  108.         (and
  109.           (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
  110.           (setq gr (grread))
  111.           (/= (car gr) 3)
  112.           (not (equal gr (list 2 13)))
  113.         )
  114.       )
  115.       (if (vl-catch-all-error-p ctch)
  116.         ctch
  117.       )
  118.     )
  119.  
  120.     (defun apply_cadr->car ( sysvarvaluepair / ctch )
  121.       (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
  122.       (if (vl-catch-all-error-p ctch)
  123.         (progn
  124.           (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
  125.           (catch_cont ctch)
  126.         )
  127.       )
  128.     )
  129.  
  130.     (defun ftoa ( n / m a s b )
  131.       (if (numberp n)
  132.         (progn
  133.           (setq m (fix ((if (< n 0) - +) n 1e-8)))
  134.           (setq a (abs (- n m)))
  135.           (setq m (itoa m))
  136.           (setq s "")
  137.           (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
  138.             (setq s (strcat s (itoa b)))
  139.             (setq a (- (* a 10.0) b))
  140.           )
  141.           (if (= (type n) (quote int))
  142.             m
  143.             (if (= s "")
  144.               m
  145.               (if (and (= m "0") (< n 0))
  146.                 (strcat "-" m "." s)
  147.                 (strcat m "." s)
  148.               )
  149.             )
  150.           )
  151.         )
  152.       )
  153.     )
  154.  
  155.     (setq sysvarpreset
  156.       (list
  157.         (list (quote cmdecho) 0)
  158.         (list (quote 3dosmode) 0)
  159.         (list (quote osmode) 0)
  160.         (list (quote unitmode) 0)
  161.         (list (quote cmddia) 0)
  162.         (list (quote ucsvp) 0)
  163.         (list (quote ucsortho) 0)
  164.         (list (quote projmode) 0)
  165.         (list (quote orbitautotarget) 0)
  166.         (list (quote insunits) 0)
  167.         (list (quote hpseparate) 0)
  168.         (list (quote hpgaptol) 0)
  169.         (list (quote halogap) 0)
  170.         (list (quote edgemode) 0)
  171.         (list (quote pickdrag) 0)
  172.         (list (quote qtextmode) 0)
  173.         (list (quote dragsnap) 0)
  174.         (list (quote angdir) 0)
  175.         (list (quote aunits) 0)
  176.         (list (quote limcheck) 0)
  177.         (list (quote gridmode) 0)
  178.         (list (quote nomutt) 0)
  179.         (list (quote apbox) 0)
  180.         (list (quote attdia) 0)
  181.         (list (quote blipmode) 0)
  182.         (list (quote copymode) 0)
  183.         (list (quote circlerad) 0.0)
  184.         (list (quote filletrad) 0.0)
  185.         (list (quote filedia) 1)
  186.         (list (quote autosnap) 1)
  187.         (list (quote objectisolationmode) 1)
  188.         (list (quote highlight) 1)
  189.         (list (quote lispinit) 1)
  190.         (list (quote layerpmode) 1)
  191.         (list (quote fillmode) 1)
  192.         (list (quote dragmodeinterrupt) 1)
  193.         (list (quote dispsilh) 1)
  194.         (list (quote fielddisplay) 1)
  195.         (list (quote deletetool) 1)
  196.         (list (quote delobj) 1)
  197.         (list (quote dblclkedit) 1)
  198.         (list (quote attreq) 1)
  199.         (list (quote explmode) 1)
  200.         (list (quote frameselection) 1)
  201.         (list (quote ltgapselection) 1)
  202.         (list (quote pickfirst) 1)
  203.         (list (quote plinegen) 1)
  204.         (list (quote plinetype) 1)
  205.         (list (quote peditaccept) 1)
  206.         (list (quote solidcheck) 1)
  207.         (list (quote visretain) 1)
  208.         (list (quote regenmode) 1)
  209.         (list (quote celtscale) 1.0)
  210.         (list (quote ltscale) 1.0)
  211.         (list (quote osnapcoord) 2)
  212.         (list (quote grips) 2)
  213.         (list (quote dragmode) 2)
  214.         (list (quote lunits) 2)
  215.         (list (quote pickstyle) 3)
  216.         (list (quote navvcubedisplay) 3)
  217.         (list (quote pickauto) 3)
  218.         (list (quote draworderctl) 3)
  219.         (list (quote expert) 5)
  220.         (list (quote auprec) 6)
  221.         (list (quote luprec) 6)
  222.         (list (quote pickbox) 6)
  223.         (list (quote aperture) 6)
  224.         (list (quote osoptions) 7)
  225.         (list (quote dimzin) 8)
  226.         (list (quote pdmode) 35)
  227.         (list (quote pdsize) -1.5)
  228.         (list (quote celweight) -1)
  229.         (list (quote cecolor) "BYLAYER")
  230.         (list (quote celtype) "ByLayer")
  231.         (list (quote clayer) "0")
  232.       )
  233.     )
  234.     (setq sysvarlst (mapcar (function car) sysvarpreset))
  235.     (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  236.     (setq sysvarvals
  237.       (vl-remove nil
  238.         (mapcar
  239.           (function (lambda ( x )
  240.             (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
  241.           ))
  242.           sysvarlst
  243.         )
  244.       )
  245.     )
  246.     (setq sysvarlst
  247.       (vl-remove-if-not
  248.         (function (lambda ( x )
  249.           (getvar x)
  250.         ))
  251.         sysvarlst
  252.       )
  253.     )
  254.     (setq initvalueslst
  255.       (apply (function mapcar)
  256.         (cons (function list)
  257.           (list
  258.             sysvarlst
  259.             (mapcar (function getvar) sysvarlst)
  260.           )
  261.         )
  262.       )
  263.     )
  264.       (cons (function setvar)
  265.         (list
  266.           sysvarlst
  267.           sysvarvals
  268.         )
  269.       )
  270.     )
  271.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  272.       (if (not (exe (list "_.UNDO" "_E")))
  273.         (if doc
  274.           (vla-endundomark doc)
  275.         )
  276.       )
  277.     )
  278.     (if (not (exe (list "_.UNDO" "_M")))
  279.       (if doc
  280.         (vla-startundomark doc)
  281.       )
  282.     )
  283.     (if wcs
  284.       (if (= 0 (getvar (quote worlducs)))
  285.         (progn
  286.           (setq ucsf
  287.             (list
  288.               (getvar (quote ucsxdir))
  289.               (getvar (quote ucsydir))
  290.               (trans (list 0.0 0.0 1.0) 1 0 t)
  291.             )
  292.           )
  293.           (exe (list "_.UCS" "_W"))
  294.         )
  295.       )
  296.     )
  297.     wcs
  298.   )
  299.  
  300.   (defun groupbynum ( lst n / sub lll )
  301.  
  302.     (defun sub ( m n / ll q )
  303.       (cond
  304.         ( (and m (< (length m) n))
  305.           (repeat (- n (length m))
  306.             (setq m (append m (list nil)))
  307.           )
  308.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  309.           (setq lll (cons ll lll))
  310.           (setq q nil)
  311.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  312.         )
  313.         ( m
  314.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  315.           (setq lll (cons ll lll))
  316.           (setq q nil)
  317.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  318.         )
  319.         ( t
  320.           (reverse lll)
  321.         )
  322.       )
  323.     )
  324.  
  325.     (sub lst n)
  326.   )
  327.  
  328.   (setq wcs (tttt t)) ;;; starting "library" template sub function - initialization ;;;
  329.   (prompt "\nSelect 3DSOLID entity to align UCS...")
  330.   (if (setq ss (ssget "_+.:E:S" (list (cons 0 "3DSOLID"))))
  331.     (progn
  332.       (setq ti (car (_vl-times)))
  333.       (exe (list "_.UNDO" "_G"))
  334.       (if (setq el (ssname ss 0))
  335.         (progn
  336.           (setq vecs (safearray-value (variant-value (vla-get-principaldirections (setq obj (vlax-ename->vla-object el))))))
  337.           (setq cent (safearray-value (variant-value (vla-get-centroid obj))))
  338.         )
  339.       )
  340.       (setq vecs (groupbynum vecs 3))
  341.       (exe (list "_.UCS" "_3P" "_non" (trans cent 0 1) "_non" (mapcar (function +) (trans cent 0 1) (car vecs)) "_non" (mapcar (function +) (trans cent 0 1) (cadr vecs))))
  342.       (setq bp (getpoint (trans cent 0 1) "\nPick or specify base point (center or point on horizontal face of 3DSOLID) : "))
  343.       (exe (list "_.UCS" "_M" "_non" bp))
  344.       (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
  345.       (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  346.     )
  347.   )
  348.   (*error* nil)
  349. )
  350.  

HTH.
M.R.
« Last Edit: September 06, 2023, 12:08:24 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #6 on: February 17, 2023, 09:40:36 AM »
You have to set UCS probably with my previous routine and then here you are with slicing along YZ, ZX and XY planes...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:slice-xyz ( / *error* tttt wcs initvalueslst ucsf ti ss el s )
  2.  
  3.   (defun *error* ( m )
  4.     (if wcs
  5.       (if ucsf
  6.         (while
  7.           (not
  8.             (and
  9.               (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
  10.               (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
  11.               (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
  12.             )
  13.           )
  14.           (exe (list "_.UCS" "_P"))
  15.         )
  16.       )
  17.     )
  18.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  19.       (if (not (exe (list "_.UNDO" "_E")))
  20.         (if doc
  21.           (vla-endundomark doc)
  22.         )
  23.       )
  24.     )
  25.     (if initvalueslst
  26.       (mapcar (function apply_cadr->car) initvalueslst)
  27.     )
  28.     (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
  29.       (setq fun nil)
  30.     )
  31.     (if doc
  32.       (vla-regen doc acactiveviewport)
  33.     )
  34.     (if m
  35.       (prompt m)
  36.     )
  37.     (princ)
  38.   )
  39.  
  40.   (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;
  41.  
  42.     (defun vl-load nil
  43.       (or cad
  44.           (setq cad (vlax-get-acad-object))
  45.           (progn
  46.             (vl-load-com)
  47.             (setq cad (vlax-get-acad-object))
  48.           )
  49.         )
  50.       )
  51.       (or doc (setq doc (vla-get-activedocument cad)))
  52.       (or alo (setq alo (vla-get-activelayout doc)))
  53.       (or spc (setq spc (vla-get-block alo)))
  54.     )
  55.  
  56.     ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  57.     (or (and cad doc alo spc) (vl-load))
  58.  
  59.     (defun exe ( tokenslist )
  60.       ( (lambda ( tokenslist / ctch )
  61.           (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
  62.             (progn
  63.               (cmderr tokenslist)
  64.               (catch_cont ctch)
  65.             )
  66.             (progn
  67.               (while (< 0 (getvar (quote cmdactive)))
  68.                 (vl-cmdf "")
  69.               )
  70.               t
  71.             )
  72.           )
  73.         )
  74.         tokenslist
  75.       )
  76.     )
  77.  
  78.     (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
  79.       (if command-s
  80.         (if flag
  81.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
  82.             flag
  83.             ctch
  84.           )
  85.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
  86.             ctch
  87.           )
  88.         )
  89.         (if flag
  90.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
  91.             flag
  92.             ctch
  93.           )
  94.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
  95.             ctch
  96.           )
  97.         )
  98.       )
  99.     )
  100.  
  101.     (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
  102.       (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
  103.     )
  104.  
  105.     (defun catch_cont ( ctch / gr )
  106.       (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
  107.       (while
  108.         (and
  109.           (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
  110.           (setq gr (grread))
  111.           (/= (car gr) 3)
  112.           (not (equal gr (list 2 13)))
  113.         )
  114.       )
  115.       (if (vl-catch-all-error-p ctch)
  116.         ctch
  117.       )
  118.     )
  119.  
  120.     (defun apply_cadr->car ( sysvarvaluepair / ctch )
  121.       (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
  122.       (if (vl-catch-all-error-p ctch)
  123.         (progn
  124.           (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
  125.           (catch_cont ctch)
  126.         )
  127.       )
  128.     )
  129.  
  130.     (defun ftoa ( n / m a s b )
  131.       (if (numberp n)
  132.         (progn
  133.           (setq m (fix ((if (< n 0) - +) n 1e-8)))
  134.           (setq a (abs (- n m)))
  135.           (setq m (itoa m))
  136.           (setq s "")
  137.           (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
  138.             (setq s (strcat s (itoa b)))
  139.             (setq a (- (* a 10.0) b))
  140.           )
  141.           (if (= (type n) (quote int))
  142.             m
  143.             (if (= s "")
  144.               m
  145.               (if (and (= m "0") (< n 0))
  146.                 (strcat "-" m "." s)
  147.                 (strcat m "." s)
  148.               )
  149.             )
  150.           )
  151.         )
  152.       )
  153.     )
  154.  
  155.     (setq sysvarpreset
  156.       (list
  157.         (list (quote cmdecho) 0)
  158.         (list (quote 3dosmode) 0)
  159.         (list (quote osmode) 0)
  160.         (list (quote unitmode) 0)
  161.         (list (quote cmddia) 0)
  162.         (list (quote ucsvp) 0)
  163.         (list (quote ucsortho) 0)
  164.         (list (quote projmode) 0)
  165.         (list (quote orbitautotarget) 0)
  166.         (list (quote insunits) 0)
  167.         (list (quote hpseparate) 0)
  168.         (list (quote hpgaptol) 0)
  169.         (list (quote halogap) 0)
  170.         (list (quote edgemode) 0)
  171.         (list (quote pickdrag) 0)
  172.         (list (quote qtextmode) 0)
  173.         (list (quote dragsnap) 0)
  174.         (list (quote angdir) 0)
  175.         (list (quote aunits) 0)
  176.         (list (quote limcheck) 0)
  177.         (list (quote gridmode) 0)
  178.         (list (quote nomutt) 0)
  179.         (list (quote apbox) 0)
  180.         (list (quote attdia) 0)
  181.         (list (quote blipmode) 0)
  182.         (list (quote copymode) 0)
  183.         (list (quote circlerad) 0.0)
  184.         (list (quote filletrad) 0.0)
  185.         (list (quote filedia) 1)
  186.         (list (quote autosnap) 1)
  187.         (list (quote objectisolationmode) 1)
  188.         (list (quote highlight) 1)
  189.         (list (quote lispinit) 1)
  190.         (list (quote layerpmode) 1)
  191.         (list (quote fillmode) 1)
  192.         (list (quote dragmodeinterrupt) 1)
  193.         (list (quote dispsilh) 1)
  194.         (list (quote fielddisplay) 1)
  195.         (list (quote deletetool) 1)
  196.         (list (quote delobj) 1)
  197.         (list (quote dblclkedit) 1)
  198.         (list (quote attreq) 1)
  199.         (list (quote explmode) 1)
  200.         (list (quote frameselection) 1)
  201.         (list (quote ltgapselection) 1)
  202.         (list (quote pickfirst) 1)
  203.         (list (quote plinegen) 1)
  204.         (list (quote plinetype) 1)
  205.         (list (quote peditaccept) 1)
  206.         (list (quote solidcheck) 1)
  207.         (list (quote visretain) 1)
  208.         (list (quote regenmode) 1)
  209.         (list (quote celtscale) 1.0)
  210.         (list (quote ltscale) 1.0)
  211.         (list (quote osnapcoord) 2)
  212.         (list (quote grips) 2)
  213.         (list (quote dragmode) 2)
  214.         (list (quote lunits) 2)
  215.         (list (quote pickstyle) 3)
  216.         (list (quote navvcubedisplay) 3)
  217.         (list (quote pickauto) 3)
  218.         (list (quote draworderctl) 3)
  219.         (list (quote expert) 5)
  220.         (list (quote auprec) 6)
  221.         (list (quote luprec) 6)
  222.         (list (quote pickbox) 6)
  223.         (list (quote aperture) 6)
  224.         (list (quote osoptions) 7)
  225.         (list (quote dimzin) 8)
  226.         (list (quote pdmode) 35)
  227.         (list (quote pdsize) -1.5)
  228.         (list (quote celweight) -1)
  229.         (list (quote cecolor) "BYLAYER")
  230.         (list (quote celtype) "ByLayer")
  231.         (list (quote clayer) "0")
  232.       )
  233.     )
  234.     (setq sysvarlst (mapcar (function car) sysvarpreset))
  235.     (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  236.     (setq sysvarvals
  237.       (vl-remove nil
  238.         (mapcar
  239.           (function (lambda ( x )
  240.             (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
  241.           ))
  242.           sysvarlst
  243.         )
  244.       )
  245.     )
  246.     (setq sysvarlst
  247.       (vl-remove-if-not
  248.         (function (lambda ( x )
  249.           (getvar x)
  250.         ))
  251.         sysvarlst
  252.       )
  253.     )
  254.     (setq initvalueslst
  255.       (apply (function mapcar)
  256.         (cons (function list)
  257.           (list
  258.             sysvarlst
  259.             (mapcar (function getvar) sysvarlst)
  260.           )
  261.         )
  262.       )
  263.     )
  264.       (cons (function setvar)
  265.         (list
  266.           sysvarlst
  267.           sysvarvals
  268.         )
  269.       )
  270.     )
  271.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  272.       (if (not (exe (list "_.UNDO" "_E")))
  273.         (if doc
  274.           (vla-endundomark doc)
  275.         )
  276.       )
  277.     )
  278.     (if (not (exe (list "_.UNDO" "_M")))
  279.       (if doc
  280.         (vla-startundomark doc)
  281.       )
  282.     )
  283.     (if wcs
  284.       (if (= 0 (getvar (quote worlducs)))
  285.         (progn
  286.           (setq ucsf
  287.             (list
  288.               (getvar (quote ucsxdir))
  289.               (getvar (quote ucsydir))
  290.               (trans (list 0.0 0.0 1.0) 1 0 t)
  291.             )
  292.           )
  293.           (exe (list "_.UCS" "_W"))
  294.         )
  295.       )
  296.     )
  297.     wcs
  298.   )
  299.  
  300.   (setq wcs (tttt nil)) ;;; starting "library" template sub function - initialization ;;;
  301.   (prompt "\nSelect 3DSOLID on unlocked Layer to perform multiple XYZ planes slicing with current UCS...")
  302.   (if (setq ss (ssget "_+.:E:S" (list (cons 0 "3DSOLID"))))
  303.     (progn
  304.       (setq ti (car (_vl-times)))
  305.       (setq el (entlast))
  306.       (exe (list "_.SLICE" ss "" "_XY" "" "_B"))
  307.       (setq s (ssadd))
  308.       (if (not (vlax-erased-p (ssname ss 0)))
  309.         (progn
  310.           (ssadd (ssname ss 0) s)
  311.           (if (entnext el)
  312.             (ssadd (entnext el) s)
  313.           )
  314.         )
  315.       )
  316.       (exe (list "_.SLICE" s "" "_YZ" "" "_B"))
  317.       (setq s (ssadd))
  318.       (while (setq el (entnext el))
  319.         (ssadd el s)
  320.       )
  321.       (if (not (vlax-erased-p (ssname ss 0)))
  322.         (ssadd (ssname ss 0) s)
  323.       )
  324.       (exe (list "_.SLICE" s "" "_ZX" "" "_B"))
  325.       (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
  326.       (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  327.     )
  328.   )
  329.   (*error* nil)
  330. )
  331.  

HTH.
M.R.
« Last Edit: September 06, 2023, 11:55:33 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #7 on: February 17, 2023, 10:39:35 AM »
Here is after slicing some xedges sweepings...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:sweep-xedges ( / *error* tttt wcs initvalueslst ucsf ti ss r i 3ds el ell )
  2.  
  3.   (defun *error* ( m )
  4.     (if wcs
  5.       (if ucsf
  6.         (while
  7.           (not
  8.             (and
  9.               (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
  10.               (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
  11.               (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
  12.             )
  13.           )
  14.           (exe (list "_.UCS" "_P"))
  15.         )
  16.       )
  17.     )
  18.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  19.       (if (not (exe (list "_.UNDO" "_E")))
  20.         (if doc
  21.           (vla-endundomark doc)
  22.         )
  23.       )
  24.     )
  25.     (if initvalueslst
  26.       (mapcar (function apply_cadr->car) initvalueslst)
  27.     )
  28.     (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
  29.       (setq fun nil)
  30.     )
  31.     (if doc
  32.       (vla-regen doc acactiveviewport)
  33.     )
  34.     (if m
  35.       (prompt m)
  36.     )
  37.     (princ)
  38.   )
  39.  
  40.   (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;
  41.  
  42.     (defun vl-load nil
  43.       (or cad
  44.           (setq cad (vlax-get-acad-object))
  45.           (progn
  46.             (vl-load-com)
  47.             (setq cad (vlax-get-acad-object))
  48.           )
  49.         )
  50.       )
  51.       (or doc (setq doc (vla-get-activedocument cad)))
  52.       (or alo (setq alo (vla-get-activelayout doc)))
  53.       (or spc (setq spc (vla-get-block alo)))
  54.     )
  55.  
  56.     ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  57.     (or (and cad doc alo spc) (vl-load))
  58.  
  59.     (defun exe ( tokenslist )
  60.       ( (lambda ( tokenslist / ctch )
  61.           (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
  62.             (progn
  63.               (cmderr tokenslist)
  64.               (catch_cont ctch)
  65.             )
  66.             (progn
  67.               (while (< 0 (getvar (quote cmdactive)))
  68.                 (vl-cmdf "")
  69.               )
  70.               t
  71.             )
  72.           )
  73.         )
  74.         tokenslist
  75.       )
  76.     )
  77.  
  78.     (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
  79.       (if command-s
  80.         (if flag
  81.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
  82.             flag
  83.             ctch
  84.           )
  85.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
  86.             ctch
  87.           )
  88.         )
  89.         (if flag
  90.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
  91.             flag
  92.             ctch
  93.           )
  94.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
  95.             ctch
  96.           )
  97.         )
  98.       )
  99.     )
  100.  
  101.     (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
  102.       (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
  103.     )
  104.  
  105.     (defun catch_cont ( ctch / gr )
  106.       (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
  107.       (while
  108.         (and
  109.           (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
  110.           (setq gr (grread))
  111.           (/= (car gr) 3)
  112.           (not (equal gr (list 2 13)))
  113.         )
  114.       )
  115.       (if (vl-catch-all-error-p ctch)
  116.         ctch
  117.       )
  118.     )
  119.  
  120.     (defun apply_cadr->car ( sysvarvaluepair / ctch )
  121.       (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
  122.       (if (vl-catch-all-error-p ctch)
  123.         (progn
  124.           (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
  125.           (catch_cont ctch)
  126.         )
  127.       )
  128.     )
  129.  
  130.     (defun ftoa ( n / m a s b )
  131.       (if (numberp n)
  132.         (progn
  133.           (setq m (fix ((if (< n 0) - +) n 1e-8)))
  134.           (setq a (abs (- n m)))
  135.           (setq m (itoa m))
  136.           (setq s "")
  137.           (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
  138.             (setq s (strcat s (itoa b)))
  139.             (setq a (- (* a 10.0) b))
  140.           )
  141.           (if (= (type n) (quote int))
  142.             m
  143.             (if (= s "")
  144.               m
  145.               (if (and (= m "0") (< n 0))
  146.                 (strcat "-" m "." s)
  147.                 (strcat m "." s)
  148.               )
  149.             )
  150.           )
  151.         )
  152.       )
  153.     )
  154.  
  155.     (setq sysvarpreset
  156.       (list
  157.         (list (quote cmdecho) 0)
  158.         (list (quote 3dosmode) 0)
  159.         (list (quote osmode) 0)
  160.         (list (quote unitmode) 0)
  161.         (list (quote cmddia) 0)
  162.         (list (quote ucsvp) 0)
  163.         (list (quote ucsortho) 0)
  164.         (list (quote projmode) 0)
  165.         (list (quote orbitautotarget) 0)
  166.         (list (quote insunits) 0)
  167.         (list (quote hpseparate) 0)
  168.         (list (quote hpgaptol) 0)
  169.         (list (quote halogap) 0)
  170.         (list (quote edgemode) 0)
  171.         (list (quote pickdrag) 0)
  172.         (list (quote qtextmode) 0)
  173.         (list (quote dragsnap) 0)
  174.         (list (quote angdir) 0)
  175.         (list (quote aunits) 0)
  176.         (list (quote limcheck) 0)
  177.         (list (quote gridmode) 0)
  178.         (list (quote nomutt) 0)
  179.         (list (quote apbox) 0)
  180.         (list (quote attdia) 0)
  181.         (list (quote blipmode) 0)
  182.         (list (quote copymode) 0)
  183.         (list (quote circlerad) 0.0)
  184.         (list (quote filletrad) 0.0)
  185.         (list (quote filedia) 1)
  186.         (list (quote autosnap) 1)
  187.         (list (quote objectisolationmode) 1)
  188.         (list (quote highlight) 1)
  189.         (list (quote lispinit) 1)
  190.         (list (quote layerpmode) 1)
  191.         (list (quote fillmode) 1)
  192.         (list (quote dragmodeinterrupt) 1)
  193.         (list (quote dispsilh) 1)
  194.         (list (quote fielddisplay) 1)
  195.         (list (quote deletetool) 1)
  196.         (list (quote delobj) 1)
  197.         (list (quote dblclkedit) 1)
  198.         (list (quote attreq) 1)
  199.         (list (quote explmode) 1)
  200.         (list (quote frameselection) 1)
  201.         (list (quote ltgapselection) 1)
  202.         (list (quote pickfirst) 1)
  203.         (list (quote plinegen) 1)
  204.         (list (quote plinetype) 1)
  205.         (list (quote peditaccept) 1)
  206.         (list (quote solidcheck) 1)
  207.         (list (quote visretain) 1)
  208.         (list (quote regenmode) 1)
  209.         (list (quote celtscale) 1.0)
  210.         (list (quote ltscale) 1.0)
  211.         (list (quote osnapcoord) 2)
  212.         (list (quote grips) 2)
  213.         (list (quote dragmode) 2)
  214.         (list (quote lunits) 2)
  215.         (list (quote pickstyle) 3)
  216.         (list (quote navvcubedisplay) 3)
  217.         (list (quote pickauto) 3)
  218.         (list (quote draworderctl) 3)
  219.         (list (quote expert) 5)
  220.         (list (quote auprec) 6)
  221.         (list (quote luprec) 6)
  222.         (list (quote pickbox) 6)
  223.         (list (quote aperture) 6)
  224.         (list (quote osoptions) 7)
  225.         (list (quote dimzin) 8)
  226.         (list (quote pdmode) 35)
  227.         (list (quote pdsize) -1.5)
  228.         (list (quote celweight) -1)
  229.         (list (quote cecolor) "BYLAYER")
  230.         (list (quote celtype) "ByLayer")
  231.         (list (quote clayer) "0")
  232.       )
  233.     )
  234.     (setq sysvarlst (mapcar (function car) sysvarpreset))
  235.     (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  236.     (setq sysvarvals
  237.       (vl-remove nil
  238.         (mapcar
  239.           (function (lambda ( x )
  240.             (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
  241.           ))
  242.           sysvarlst
  243.         )
  244.       )
  245.     )
  246.     (setq sysvarlst
  247.       (vl-remove-if-not
  248.         (function (lambda ( x )
  249.           (getvar x)
  250.         ))
  251.         sysvarlst
  252.       )
  253.     )
  254.     (setq initvalueslst
  255.       (apply (function mapcar)
  256.         (cons (function list)
  257.           (list
  258.             sysvarlst
  259.             (mapcar (function getvar) sysvarlst)
  260.           )
  261.         )
  262.       )
  263.     )
  264.       (cons (function setvar)
  265.         (list
  266.           sysvarlst
  267.           sysvarvals
  268.         )
  269.       )
  270.     )
  271.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  272.       (if (not (exe (list "_.UNDO" "_E")))
  273.         (if doc
  274.           (vla-endundomark doc)
  275.         )
  276.       )
  277.     )
  278.     (if (not (exe (list "_.UNDO" "_M")))
  279.       (if doc
  280.         (vla-startundomark doc)
  281.       )
  282.     )
  283.     (if wcs
  284.       (if (= 0 (getvar (quote worlducs)))
  285.         (progn
  286.           (setq ucsf
  287.             (list
  288.               (getvar (quote ucsxdir))
  289.               (getvar (quote ucsydir))
  290.               (trans (list 0.0 0.0 1.0) 1 0 t)
  291.             )
  292.           )
  293.           (exe (list "_.UCS" "_W"))
  294.         )
  295.       )
  296.     )
  297.     wcs
  298.   )
  299.  
  300.   (setq wcs (tttt t)) ;;; starting "library" template sub function - initialization ;;;
  301.   (if
  302.     (and
  303.       (setq ss (ssget "_:L" (list (cons 0 "3DSOLID"))))
  304.       (not (initget 7))
  305.       (setq r (getdist "\nPick or specify radius of circle for sweeping operation : "))
  306.       (not (initget 1 "Yes No"))
  307.       (setq ch (getkword "\nDo you want to keep curves after processing XEDGES [Yes / No] : "))
  308.     )
  309.     (progn
  310.       (setq ti (car (_vl-times)))
  311.       (repeat (setq i (sslength ss))
  312.         (setq 3ds (ssname ss (setq i (1- i))))
  313.         (setq el (entlast))
  314.         (exe (list "_.XEDGES" 3ds ""))
  315.         (while (setq el (entnext el))
  316.           (setq ell (cons el ell))
  317.         )
  318.         (foreach el ell
  319.           (exe (list "_.CIRCLE" "_non" (list 0.0 0.0 0.0) r))
  320.           (exe (list "_.SWEEP" "_L" "" el))
  321.         )
  322.         (if (= ch "No")
  323.           (foreach el ell
  324.             (entdel el)
  325.           )
  326.         )
  327.         (setq ell nil)
  328.       )
  329.       (prompt "\nElapsed time : ") (prompt (ftoa (- (car (_vl-times)) ti))) (prompt " milliseconds...")
  330.       (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
  331.     )
  332.   )
  333.   (*error* nil)
  334. )
  335.  

HTH.
M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #8 on: February 21, 2023, 01:55:40 PM »
I find this also useful... Regards, M.R.

Code - Auto/Visual Lisp: [Select]
  1. (defun c:normalize-3ds-MR ( / *error* tttt wcs initvalueslst ucsf ti groupbynum Mat:trp Mat:mxv Mat:mxm invm imat s ch bp ss ent obj vecs mat1 mat2 )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if wcs
  6.       (if ucsf
  7.         (while
  8.           (not
  9.             (and
  10.               (equal (getvar (quote ucsxdir)) (car ucsf) 1e-6)
  11.               (equal (getvar (quote ucsydir)) (cadr ucsf) 1e-6)
  12.               (equal (trans (list 0.0 0.0 1.0) 1 0 t) (caddr ucsf) 1e-6)
  13.             )
  14.           )
  15.           (exe (list "_.UCS" "_P"))
  16.         )
  17.       )
  18.     )
  19.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  20.       (if (not (exe (list "_.UNDO" "_E")))
  21.         (if doc
  22.           (vla-endundomark doc)
  23.         )
  24.       )
  25.     )
  26.     (if initvalueslst
  27.       (mapcar (function apply_cadr->car) initvalueslst)
  28.     )
  29.     (foreach fun (list (quote tttt) (quote vl-load) (quote exe) (quote cmdfun) (quote cmderr) (quote catch_cont) (quote apply_cadr->car) (quote ftoa))
  30.       (setq fun nil)
  31.     )
  32.     (if doc
  33.       (vla-regen doc acactiveviewport)
  34.     )
  35.     (if m
  36.       (prompt m)
  37.     )
  38.     (princ)
  39.   )
  40.  
  41.   (defun tttt ( wcs / sysvarpreset sysvarlst sysvarvals ) ;;; wcs (T/nil) ;;; cad, doc, alo, spc - global variables (Visual Lisp main VLA-OBJECT pointers) ;;; vl-load exe cmdfun cmderr catch_cont apply_cadr->car ftoa - library sub functions common for standard template initialization ;;;
  42.  
  43.     (defun vl-load nil
  44.       (or cad
  45.           (setq cad (vlax-get-acad-object))
  46.           (progn
  47.             (vl-load-com)
  48.             (setq cad (vlax-get-acad-object))
  49.           )
  50.         )
  51.       )
  52.       (or doc (setq doc (vla-get-activedocument cad)))
  53.       (or alo (setq alo (vla-get-activelayout doc)))
  54.       (or spc (setq spc (vla-get-block alo)))
  55.     )
  56.  
  57.     ;;; sometimes not needed to use/initialize AxiveX Visual Lisp extensions - (comment/uncomment) following line ;;;
  58.     (or (and cad doc alo spc) (vl-load))
  59.  
  60.     (defun exe ( tokenslist )
  61.       ( (lambda ( tokenslist / ctch )
  62.           (if (vl-catch-all-error-p (setq ctch (cmdfun tokenslist t)))
  63.             (progn
  64.               (cmderr tokenslist)
  65.               (catch_cont ctch)
  66.             )
  67.             (progn
  68.               (while (< 0 (getvar (quote cmdactive)))
  69.                 (vl-cmdf "")
  70.               )
  71.               t
  72.             )
  73.           )
  74.         )
  75.         tokenslist
  76.       )
  77.     )
  78.  
  79.     (defun cmdfun ( tokenslist flag / ctch ) ;;; tokenslist - command parameters list of strings ;;; flag - if "t" specified, upon successful execution returns t, otherwise if "nil" specified, return is always nil no matter what outcome of function execution is - it should be successful anyway if specified tokenslist was hardcoded correctly... ;;;
  80.       (if command-s
  81.         (if flag
  82.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist))))
  83.             flag
  84.             ctch
  85.           )
  86.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command-s) tokenslist)))
  87.             ctch
  88.           )
  89.         )
  90.         (if flag
  91.           (if (not (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function vl-cmdf) tokenslist))))
  92.             flag
  93.             ctch
  94.           )
  95.           (if (vl-catch-all-error-p (setq ctch (vl-catch-all-apply (function command) tokenslist)))
  96.             ctch
  97.           )
  98.         )
  99.       )
  100.     )
  101.  
  102.     (defun cmderr ( tokenslist ) ;;; tokenslist - list of tokens representing command syntax at which used (cmdfun) failed with successful execution ;;;
  103.       (prompt (strcat "\ncommand execution failure... error at used command tokenslist : " (vl-prin1-to-string tokenslist)))
  104.     )
  105.  
  106.     (defun catch_cont ( ctch / gr )
  107.       (prompt "\nleft mouse click to continue or enter to generate catch error - ESC to break...")
  108.       (while
  109.         (and
  110.           (vl-catch-all-error-p (or ctch (setq ctch (vl-catch-all-apply (function /) (list 1 0)))))
  111.           (setq gr (grread))
  112.           (/= (car gr) 3)
  113.           (not (equal gr (list 2 13)))
  114.         )
  115.       )
  116.       (if (vl-catch-all-error-p ctch)
  117.         ctch
  118.       )
  119.     )
  120.  
  121.     (defun apply_cadr->car ( sysvarvaluepair / ctch )
  122.       (setq ctch (vl-catch-all-apply (function setvar) sysvarvaluepair))
  123.       (if (vl-catch-all-error-p ctch)
  124.         (progn
  125.           (prompt (strcat "\ncatched error on setting system variable : " (vl-prin1-to-string (vl-symbol-name (car sysvarvaluepair))) " with value : " (vl-prin1-to-string (cadr sysvarvaluepair))))
  126.           (catch_cont ctch)
  127.         )
  128.       )
  129.     )
  130.  
  131.     (defun ftoa ( n / m a s b )
  132.       (if (numberp n)
  133.         (progn
  134.           (setq m (fix ((if (< n 0) - +) n 1e-8)))
  135.           (setq a (abs (- n m)))
  136.           (setq m (itoa m))
  137.           (setq s "")
  138.           (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
  139.             (setq s (strcat s (itoa b)))
  140.             (setq a (- (* a 10.0) b))
  141.           )
  142.           (if (= (type n) (quote int))
  143.             m
  144.             (if (= s "")
  145.               m
  146.               (if (and (= m "0") (< n 0))
  147.                 (strcat "-" m "." s)
  148.                 (strcat m "." s)
  149.               )
  150.             )
  151.           )
  152.         )
  153.       )
  154.     )
  155.  
  156.     (setq sysvarpreset
  157.       (list
  158.         (list (quote cmdecho) 0)
  159.         (list (quote 3dosmode) 0)
  160.         (list (quote osmode) 0)
  161.         (list (quote unitmode) 0)
  162.         (list (quote cmddia) 0)
  163.         (list (quote ucsvp) 0)
  164.         (list (quote ucsortho) 0)
  165.         (list (quote projmode) 0)
  166.         (list (quote orbitautotarget) 0)
  167.         (list (quote insunits) 0)
  168.         (list (quote hpseparate) 0)
  169.         (list (quote hpgaptol) 0)
  170.         (list (quote halogap) 0)
  171.         (list (quote edgemode) 0)
  172.         (list (quote pickdrag) 0)
  173.         (list (quote qtextmode) 0)
  174.         (list (quote dragsnap) 0)
  175.         (list (quote angdir) 0)
  176.         (list (quote aunits) 0)
  177.         (list (quote limcheck) 0)
  178.         (list (quote gridmode) 0)
  179.         (list (quote nomutt) 0)
  180.         (list (quote apbox) 0)
  181.         (list (quote attdia) 0)
  182.         (list (quote blipmode) 0)
  183.         (list (quote copymode) 0)
  184.         (list (quote circlerad) 0.0)
  185.         (list (quote filletrad) 0.0)
  186.         (list (quote filedia) 1)
  187.         (list (quote autosnap) 1)
  188.         (list (quote objectisolationmode) 1)
  189.         (list (quote highlight) 1)
  190.         (list (quote lispinit) 1)
  191.         (list (quote layerpmode) 1)
  192.         (list (quote fillmode) 1)
  193.         (list (quote dragmodeinterrupt) 1)
  194.         (list (quote dispsilh) 1)
  195.         (list (quote fielddisplay) 1)
  196.         (list (quote deletetool) 1)
  197.         (list (quote delobj) 1)
  198.         (list (quote dblclkedit) 1)
  199.         (list (quote attreq) 1)
  200.         (list (quote explmode) 1)
  201.         (list (quote frameselection) 1)
  202.         (list (quote ltgapselection) 1)
  203.         (list (quote pickfirst) 1)
  204.         (list (quote plinegen) 1)
  205.         (list (quote plinetype) 1)
  206.         (list (quote peditaccept) 1)
  207.         (list (quote solidcheck) 1)
  208.         (list (quote visretain) 1)
  209.         (list (quote regenmode) 1)
  210.         (list (quote celtscale) 1.0)
  211.         (list (quote ltscale) 1.0)
  212.         (list (quote osnapcoord) 2)
  213.         (list (quote grips) 2)
  214.         (list (quote dragmode) 2)
  215.         (list (quote lunits) 2)
  216.         (list (quote pickstyle) 3)
  217.         (list (quote navvcubedisplay) 3)
  218.         (list (quote pickauto) 3)
  219.         (list (quote draworderctl) 3)
  220.         (list (quote expert) 5)
  221.         (list (quote auprec) 6)
  222.         (list (quote luprec) 6)
  223.         (list (quote pickbox) 6)
  224.         (list (quote aperture) 6)
  225.         (list (quote osoptions) 7)
  226.         (list (quote dimzin) 8)
  227.         (list (quote pdmode) 35)
  228.         (list (quote pdsize) -1.5)
  229.         (list (quote celweight) -1)
  230.         (list (quote cecolor) "BYLAYER")
  231.         (list (quote celtype) "ByLayer")
  232.         (list (quote clayer) "0")
  233.       )
  234.     )
  235.     (setq sysvarlst (mapcar (function car) sysvarpreset))
  236.     (setq sysvarvals (mapcar (function cadr) sysvarpreset))
  237.     (setq sysvarvals
  238.       (vl-remove nil
  239.         (mapcar
  240.           (function (lambda ( x )
  241.             (if (getvar x) (nth (vl-position x sysvarlst) sysvarvals))
  242.           ))
  243.           sysvarlst
  244.         )
  245.       )
  246.     )
  247.     (setq sysvarlst
  248.       (vl-remove-if-not
  249.         (function (lambda ( x )
  250.           (getvar x)
  251.         ))
  252.         sysvarlst
  253.       )
  254.     )
  255.     (setq initvalueslst
  256.       (apply (function mapcar)
  257.         (cons (function list)
  258.           (list
  259.             sysvarlst
  260.             (mapcar (function getvar) sysvarlst)
  261.           )
  262.         )
  263.       )
  264.     )
  265.       (cons (function setvar)
  266.         (list
  267.           sysvarlst
  268.           sysvarvals
  269.         )
  270.       )
  271.     )
  272.     (while (= 8 (logand 8 (getvar (quote undoctl))))
  273.       (if (not (exe (list "_.UNDO" "_E")))
  274.         (if doc
  275.           (vla-endundomark doc)
  276.         )
  277.       )
  278.     )
  279.     (if (not (exe (list "_.UNDO" "_M")))
  280.       (if doc
  281.         (vla-startundomark doc)
  282.       )
  283.     )
  284.     (if wcs
  285.       (if (= 0 (getvar (quote worlducs)))
  286.         (progn
  287.           (setq ucsf
  288.             (list
  289.               (getvar (quote ucsxdir))
  290.               (getvar (quote ucsydir))
  291.               (trans (list 0.0 0.0 1.0) 1 0 t)
  292.             )
  293.           )
  294.           (exe (list "_.UCS" "_W"))
  295.         )
  296.       )
  297.     )
  298.     wcs
  299.   )
  300.  
  301.   (defun groupbynum ( lst n / sub lll )
  302.  
  303.     (defun sub ( m n / ll q )
  304.       (cond
  305.         ( (and m (< (length m) n))
  306.           (repeat (- n (length m))
  307.             (setq m (append m (list nil)))
  308.           )
  309.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  310.           (setq lll (cons ll lll))
  311.           (setq q nil)
  312.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  313.         )
  314.         ( m
  315.           (setq ll (vl-remove-if-not (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m))
  316.           (setq lll (cons ll lll))
  317.           (setq q nil)
  318.           (sub (vl-remove-if (function (lambda ( x ) (setq q (if (not q) 0 (1+ q))) (< q n))) m) n)
  319.         )
  320.         ( t
  321.           (reverse lll)
  322.         )
  323.       )
  324.     )
  325.  
  326.     (sub lst n)
  327.   )
  328.  
  329.   ;;;-----------------------------------------------------------;;
  330.   ;;; Mat:trp Transpose a matrix -Doug Wilson-                  ;;
  331.   ;;;-----------------------------------------------------------;;
  332.   (defun Mat:trp (m)
  333.     (apply 'mapcar (cons 'list m))
  334.   )
  335.  
  336.   ;;;-----------------------------------------------------------;;
  337.   ;;; Matrix x Vector - Vladimir Nesterovsky                    ;;
  338.   ;;; Args: m - nxn matrix, v - vector in R^n                   ;;
  339.   ;;;-----------------------------------------------------------;;
  340.   (defun Mat:mxv (m v)
  341.     (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
  342.   )
  343.  
  344.   ;;;-----------------------------------------------------------;;
  345.   ;;; Mat:mxm Multiply two matrices -Vladimir Nesterovsky-      ;;
  346.   ;;;-----------------------------------------------------------;;
  347.   (defun Mat:mxm (m q)
  348.     (mapcar (function (lambda (r) (Mat:mxv (Mat:trp q) r))) m)
  349.   )
  350.  
  351.   ;; Matrix Inverse  -  gile & Lee Mac
  352.   ;; Uses Gauss-Jordan Elimination to return the inverse of a non-singular nxn matrix.
  353.   ;; Args: m - nxn matrix
  354.  
  355.   (defun invm ( m / c f p r )
  356.  
  357.     (defun f ( p m )
  358.       (mapcar (function (lambda ( x ) (mapcar (function (lambda ( a b ) (- a (* (car x) b)))) (cdr x) p))) m)
  359.     )
  360.  
  361.     (setq  m (mapcar (function append) m (imat (length m))))
  362.     (while m
  363.       (setq c (mapcar (function (lambda ( x ) (abs (car x)))) m))
  364.       (repeat (vl-position (apply 'max c) c)
  365.         (setq m (append (cdr m) (list (car m))))
  366.       )
  367.       (if (equal 0.0 (caar m) 1e-14)
  368.         (setq m nil
  369.               r nil
  370.         )
  371.         (setq p (mapcar (function (lambda ( x ) (/ (float x) (caar m)))) (cdar m))
  372.               m (f p (cdr m))
  373.               r (cons p (f p r))
  374.         )
  375.       )
  376.     )
  377.     (reverse r)
  378.   )
  379.  
  380.   ;; Identity Matrix  -  Lee Mac
  381.   ;; Args: n - matrix dimension
  382.  
  383.   (defun imat ( n / i j l m )
  384.     (repeat (setq i n)
  385.       (repeat (setq j n)
  386.         (setq l (cons (if (= i j) 1.0 0.0) l)
  387.               j (1- j)
  388.         )
  389.       )
  390.       (setq m (cons l m)
  391.             l nil
  392.             i (1- i)
  393.       )
  394.     )
  395.     m
  396.   )
  397.  
  398.   (setq wcs (tttt t))
  399.   (initget "End Int Both Non")
  400.   (setq ch (getkword "\nSet OSMODE to [End / Int / Both / Non] <End> : "))
  401.   (cond
  402.     ( (not ch)
  403.       (setq ch "End")
  404.     )
  405.     ( (= ch "Both")
  406.       (setq ch "end,int")
  407.     )
  408.   )
  409.   (exe (list "_.OSNAP" ch))
  410.   (if
  411.     (and
  412.       (progn (prompt "\nSelect 3DSOLID you want to normalize with WCS...") t)
  413.       (setq s (ssget "_+.:E:S:L" (list (cons 0 "3DSOLID"))))
  414.       (progn (prompt "\nSelect 3DSOLIDS group aligned with base 3DSOLID you previously picked (all including base 3DSOLID)...") t)
  415.       (setq ss (ssget "_:L" (list (cons 0 "3DSOLID"))))
  416.       (setq bp (getpoint "\nPick or specify base point on 3DSOLID previously picked : "))
  417.     )
  418.     (progn
  419.       (setq ent (ssname s 0))
  420.       (setq obj (vlax-ename->vla-object ent))
  421.       (setq vecs (groupbynum vecs 3))
  422.       (setq mat1 (Mat:trp vecs))
  423.       (setq mat1 (append mat1 (list (list 0.0 0.0 0.0))))
  424.       (setq mat1 (mapcar (function (lambda ( x ) (if (equal x (list 0.0 0.0 0.0)) (append x (list 1.0)) (append x (list 0.0))))) mat1))
  425.       (setq vecs (list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0) (list 0.0 0.0 1.0)))
  426.       (setq mat2 (Mat:trp vecs))
  427.       (setq mat2 (append mat2 (list (list 0.0 0.0 0.0))))
  428.       (setq mat2 (mapcar (function (lambda ( x ) (if (equal x (list 0.0 0.0 0.0)) (append x (list 1.0)) (append x (list 0.0))))) mat2))
  429.       (foreach ent (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex ss)))
  430.         (setq obj (vlax-ename->vla-object ent))
  431.         (vla-transformby obj (vlax-tmatrix (Mat:mxm mat2 (invm mat1))))
  432.         (vla-move obj (vlax-3d-point (Mat:mxv (mapcar (function (lambda ( x ) (mapcar (function +) (list 0.0 0.0 0.0) x))) (vl-remove (last (Mat:mxm mat2 (invm mat1))) (Mat:mxm mat2 (invm mat1)))) (trans bp 1 0))) (vlax-3d-point (list 0.0 0.0 0.0)))
  433.       )
  434.     )
  435.   )
  436.   (*error* nil)
  437. )
  438.  
« Last Edit: September 06, 2023, 11:57:27 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Sudipta2020

  • Mosquito
  • Posts: 16
Re: --={ Challenge }=-- code for align3d command...
« Reply #9 on: February 22, 2023, 01:58:25 AM »
is it possible to align 3dobject using more than three references.

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #10 on: February 22, 2023, 06:27:20 AM »
is it possible to align 3dobject using more than three references.

You can somehow find reference points ether they are centroids or vertices of compound complex 3DSOLIDS with apexes - by extracting temporarily edges with XEDGES command... Then you could perhaps pull out barycenter point : (setq bc (mapcar (function /) (apply (function mapcar) (cons (function +) ptlst)) (list (length ptlst) (length ptlst) (length ptlst))))) and use it for some of 3D align purposes...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Sudipta2020

  • Mosquito
  • Posts: 16
Re: --={ Challenge }=-- code for align3d command...
« Reply #11 on: February 22, 2023, 08:18:57 AM »
I have a block which contains some reference points, from this reference points I need to align the block on as built data, in align command i can use only three references but I need more references for align
« Last Edit: February 22, 2023, 08:22:38 AM by Sudipta2020 »

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #12 on: February 22, 2023, 08:24:42 AM »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: --={ Challenge }=-- code for align3d command...
« Reply #13 on: February 22, 2023, 08:38:31 AM »
Let's see if someone has an input for Helmert transformation... I don't quite understand it for now, but I suppose ALISP is all that is needed...
https://en.wikipedia.org/wiki/Helmert_transformation

I've found these 2, but they are not freeware...
https://apps.autodesk.com/ACD/en/List/Search?isAppSearch=True&searchboxstore=ACD&facet=&collection=&sort=&query=Helmert+Transformation
« Last Edit: February 22, 2023, 08:41:47 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

pkohut

  • Bull Frog
  • Posts: 483
Re: --={ Challenge }=-- code for align3d command...
« Reply #14 on: February 22, 2023, 09:12:51 AM »
I have a block which contains some reference points, from this reference points I need to align the block on as built data, in align command i can use only three references but I need more references for align


ADETRANSFORM is an Acad Map feature. Type at command line to see if it works on your version of Acad.  If so you can do scale, rotate, move all at once.  Four points is supported.

If ADETRANSFORM is not available, there are many already tested and verified routines from

PS, just looked and the built in ALIGN command supports 4 points.
https://cadprotips.com/2016/02/27/move-rotate-and-scale-with-align-in-autocad/
New tread (not retired) - public repo at https://github.com/pkohut