;;--------------------=={ Object Align }==--------------------;;
;;                                                            ;;
;;  This program will enable the user to dynamically align a  ;;
;;  selection of objects to a selected curve, with intuitive  ;;
;;  placement controls.                                       ;;
;;                                                            ;;
;;  Upon starting the program with the command syntax 'OA',   ;;
;;  the user is prompted to make a selection of objects to    ;;
;;  be aligned. Following a valid selection, the user is      ;;
;;  prompted to specify a base point to use during alignment; ;;
;;  at this prompt, the program will use the center of the    ;;
;;  bounding box of the selection of objects by default.      ;;
;;                                                            ;;
;;  The user is then prompted to select a curve object        ;;
;;  (this may be a Line, Polyline, Arc, Circle, Ellipse,      ;;
;;  XLine, Spline etc.) to which the objects are to be        ;;
;;  aligned. The selected curve may be a primary object, or   ;;
;;  nested with a Block or XRef to any level. After           ;;
;;  selection, the program offers several controls to aid     ;;
;;  with object placement displayed at the command line:      ;;
;;                                                            ;;
;;  [+/-] for [O]ffset | [</>] for [R]otation | <[E]xit>:     ;;
;;                                                            ;;
;;  The offset of the objects from the curve may be           ;;
;;  controlled incrementally by a tenth of the object height  ;;
;;  using the '+' / '-' keys, or a specific offset may be     ;;
;;  entered upon pressing the 'O' or 'o' key.                 ;;
;;                                                            ;;
;;  The set of objects may be rotated anti-clockwise or       ;;
;;  clockwise by 45 degrees relative to the curve by pressing ;;
;;  the '<' or '>' keys respectively; alternatively, the user ;;
;;  may enter a specific rotation by pressing the 'R' or 'r'  ;;
;;  key.                                                      ;;
;;                                                            ;;
;;  Finally, the user may place the objects and exit the      ;;
;;  program by either clicking the left or right mouse        ;;
;;  buttons, pressing Enter or Space, or by pressing the 'E'  ;;
;;  or 'e' keys.                                              ;;
;;                                                            ;;
;;  The program should perform successfully in all UCS &      ;;
;;  Views, and in all versions of AutoCAD that have Visual    ;;
;;  LISP functions available (AutoCAD 2000 onwards).          ;;
;;                                                            ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2012 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Version 1.3    -    14-12-2012                            ;;
;;------------------------------------------------------------;;

(defun c:lm_oa

    (
        /
        *error*
        _copynested
        _curveobject-p
        _fixdxfdata
        _locked-p
        _selectif

        bb1 bb2 blk bnm bpt
        def dis
        enl ent
        fac
        gr1 gr2
        inc
        llp lst
        mat msg
        nrm
        obj
        pi2 pt1 pt2
        sel
        tmp
        urp uxa
    )

    (defun *error* ( msg )
        (and
            (= 'list  (type mat))
            (= 'ename (type ent))
            (entdel ent)
        )
        (and (= 'vla-object (type blk))
             (not (vlax-erased-p blk))
             (vl-catch-all-apply 'vla-delete (list blk))
        )
        (and (= 'vla-object (type def))
             (not (vlax-erased-p def))
             (vl-catch-all-apply 'vla-delete (list def))
        )
        (foreach obj lst
            (or (vlax-erased-p obj)
                (vl-catch-all-apply 'vla-delete (list obj))
            )
        )
        (LM:endundo (LM:acdoc))
        (and msg
            (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
            (princ (strcat "\n³ö´í: " msg))
        )
        (princ)
    )
    
    (defun _curveobject-p ( ent )
        (null
            (vl-catch-all-error-p
                (vl-catch-all-apply 'vlax-curve-getendparam (list ent))
            )
        )
    )

    (defun _fixdxfdata ( elst )
        (vl-remove-if '(lambda (x) (member (car x) '(5 6 8 102 330))) elst)
    )

    (defun _copynested ( ent mat / enx )
        (if
            (setq
                enx (entget ent)
                ent
                (cond
                    (   (= "VERTEX" (mai_dxf 0 enx))
                        (setq ent (mai_dxf 330 enx))
                        (entmakex (_fixdxfdata (entget ent)))
                        (setq ent (entnext ent)
                              enx (entget  ent)
                        )
                        (while (/= "SEQEND" (mai_dxf 0 enx))
                            (entmakex (_fixdxfdata enx))
                            (setq ent (entnext ent)
                                  enx (entget  ent)
                            )
                        )
                        (mai_dxf 330 (entmakex (_fixdxfdata enx)))
                    )
                    (   (entmakex (_fixdxfdata enx))   )
                )
            )
            (if mat (vla-transformby (vlax-ename->vla-object ent) (vlax-tmatrix mat)))
        )
        ent
    )

    (defun _selectif ( msg pred )
        (
            (lambda ( pred / sel )
                (while
                    (progn (setvar 'errno 0) (setq sel (nentselp msg))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\n¿ÕÑ¡, ÔÙÑ¡Ò»´Î.")
                            )
                            (   (= 'ename (type (car sel)))
                                (if (null (pred (car sel)))
                                    (princ "\nÑ¡ÔñµÄÊµÌåÀàÐÍ²»ÕýÈ·.")
                                )
                            )
                        )
                    )
                )
                sel
            )
            (eval pred)
        )
    )
    
    (defun _locked-p ( layer )
        (= 4 (logand 4 (mai_dxf 70 (tblsearch "LAYER" layer))))
    )

    (or oa|rot (setq oa|rot 0.))
    (or oa|off (setq oa|off 0.))
    (cond
        (   (or
                (_locked-p (getvar 'clayer))
                (_locked-p "0")
            )
            (princ "\n¡¾µ±Ç°²ã¡¿»òÍ¼²ã¡¾0¡¿±»Ëø¶¨.")
        )
        (   (null (setq sel (LM:ssget "\n¶àÑ¡ÐèÒª¶ÔÆëµÄÊµÌå :" '("_:L" ((0 . "~VIEWPORT"))))))
            (princ "\n*Cancel*")
        )
        (   (progn
                (setq mat
                    (vlax-tmatrix
                        (append
                            (mapcar
                               '(lambda ( a b ) (append (trans a 1 0 t) (list b)))
                               '(
                                    (1.0 0.0 0.0)
                                    (0.0 1.0 0.0)
                                    (0.0 0.0 1.0)
                                )
                                (trans '(0.0 0.0 0.0) 0 1)
                            )
                           '((0.0 0.0 0.0 1.0))
                        )
                    )
                )
                (LM:startundo (LM:acdoc))
                (repeat (setq inc (sslength sel))
                    (setq inc (1- inc)
                          obj (vla-copy (vlax-ename->vla-object (ssname sel inc)))
                          lst (cons obj lst)
                    )
                    (vla-transformby obj mat)
                    (and (vlax-method-applicable-p obj 'getboundingbox)
                         (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
                         (setq bb1 (cons (vlax-safearray->list llp) bb1)
                               bb2 (cons (vlax-safearray->list urp) bb2)
                         )
                    )
                    (vla-put-visible obj :vlax-false)
                )
                (setq bb1 (apply 'mapcar (cons 'min bb1))
                      bb2 (apply 'mapcar (cons 'max bb2))
                )
                (cond
                    (   (setq bpt (getpoint "\nÊäÈë»ù×¼µã£º<ÖÐÐÄµãCenter>"))
                        (setq bpt (trans bpt 1 0))
                    )
                    (   (setq bpt (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) bb1 bb2)))
                )
                (null (setq enl (_selectif "\nµ¥Ñ¡¶ÔÆëµ½µÄÇúÏß:" '(lambda(x) (or (= "VERTEX" (mai_dxf 0 x)) (_curveobject-p x))))))
            )
            (*error* nil)
        )
        (   (not
                (or (and
                        (setq mat (caddr enl))
                        (setq ent (_copynested (car enl) mat))
                    )
                    (and 
                        (setq pt1 (entget (car enl)))
                        (= "VERTEX" (mai_dxf 0 pt1))
                        (setq ent (mai_dxf 330 pt1))
                    )
                    (setq ent (car enl))
                )
            )
            (*error* nil)
            (princ "\nÎÞ·¨ÖØÉú³É´ËÇ¶Ì×µÄÊµÌå.")
        )
        (   t         
            (setq pt1 (cadr (grread t 9))
                  fac (/ (- (cadr bb2) (cadr bb1)) 2.)
                  nrm (trans '(0.0 0.0 1.0) 1 0 t)
                  uxa (angle '(0.0 0.0 0.0) (trans (getvar 'ucsxdir) 0 nrm t))
                  pi2 (/ pi -2.)
                  inc 0
            )
            (while (tblsearch "BLOCK" (setq inc (1+ inc) bnm (strcat "$tmp" (itoa inc)))))
            (foreach obj lst (vla-put-visible obj :vlax-true))
            (vla-copyobjects (LM:acdoc)
                (vlax-make-variant
                    (vlax-safearray-fill
                        (vlax-make-safearray vlax-vbobject (cons 0 (1- (length lst))))
                        lst
                    )
                )
                (setq def (vla-add (vla-get-blocks (LM:acdoc)) (vlax-3D-point bpt) bnm))
            )
            (foreach obj lst (vla-delete obj))
            (setq lst nil
                  blk
                (vla-insertblock
                    (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                    (vlax-3D-point (trans pt1 1 0))
                    bnm
                    1.0 1.0 1.0 0.0
                )
            )
            (vla-put-layer blk "0")
            (vla-put-normal blk (vlax-3D-point nrm))
            (setq msg (princ "\n°´[WÔö¼Ó/S¼õÉÙ/OÊäÈë]Æ«ÒÆ¾àÀë | °´[A¼õÉÙ/DÔö¼Ó/RÊäÈë]µ÷Õû½Ç¶È£º<ÍË³öE>"))

            (while
                (progn
                    (setq gr1 (grread t 15 0)
                          gr2 (cadr gr1)
                          gr1 (car  gr1)
                    )
                    (cond
                        (   (member gr1 '(3 5))
                            (setq pt2 (trans gr2 1 0)
                                  pt1 (vlax-curve-getclosestpointto ent pt2)
                                  dis (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatpoint ent pt1)))
                                  pt1 (mai_point_per2line pt2 pt1 (polar pt1 dis 5.))
                            )
                            (or (mai_equal pt1 pt2)
                                (progn
                                    (setq dis (/ (* fac oa|off) (distance pt1 pt2)))
                                    (vla-put-insertionpoint blk (vlax-3D-point (mapcar '(lambda ( a b ) (+ a (* (- b a) dis))) pt1 pt2)))
                                    (vla-put-rotation blk (+ (angle (trans pt1 0 1) gr2) uxa oa|rot pi2))
                                )
                            )
                            (= 5 gr1)
                        )
                        (   (= 2 gr1)
                            (cond
                                (   (member gr2 '(87 119)) ;'(043 061)
                                    (setq oa|off (+ oa|off 0.1))
                                )
                                (   (member gr2 '(83 115)) ;'(045 095)
                                    (setq oa|off (- oa|off 0.1))
                                )
                                (   (member gr2 '(68 100)) ;'(044 060)
                                    (setq oa|rot (+ oa|rot (/ pi 4.)))
                                )
                                (   (member gr2 '(65 97)) ;'(046 062)
                                    (setq oa|rot (- oa|rot (/ pi 4.)))
                                )
                                (   (member gr2 '(13 32 69 101))
                                    nil
                                )
                                (   (member gr2 '(82 114))
                                    (if (setq tmp (getangle (strcat "\nÊäÈëÐý×ª½Ç¶È£º<" (angtos oa|rot) ">")))
                                        (setq oa|rot tmp)
                                    )
                                    (princ msg)
                                )
                                (   (member gr2 '(79 111))
                                    (if (setq tmp (getdist (strcat "\nÊäÈëÆ«ÒÆ¾àÀë£º<" (rtos (* fac oa|off)) ">")))
                                        (setq oa|off (/ tmp fac))
                                    )
                                    (princ msg)
                                )
                                (   t   )
                            )
                        )
                        (   (member gr1 '(11 12 25)) nil)
                        (   t   )
                    )
                )
            )
            (if mat (entdel ent))
            (vla-explode blk)
            ;(vla-delete  blk)
            ;(vla-delete  def)
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;;
;; Arguments:
;; msg    - selection prompt
;; params - list of ssget arguments

(defun LM:ssget ( msg params / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget params))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
    
(princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;