Align Block to object

[ishka]

I had this awesome code from Lee Mac about aligning a block to an object and wanted to know if it can be updated to also allow for the block to maintain the location and just align from the original location. This is helpful for aligning survey block to the orientation of the road line object. The code is attached to this post.
          
             
            

        

LM_BlockAlign.lsp

[Emmanuel Delay]

 

I commented out the part that moves the block   (  vla-put-InsertionPoint ... ), so it only rotates, the insert point stays where it was.

 

;; EDIT Emmanuel Delay:  the block only rotates, it's not moved to the curve entity
;; https://www.cadtutor.net/forum/topic/67097-align-block-to-object/

;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;
;;                                                                               ;;
;;                                                                               ;;
;;                          --=={  Block Align  }==--                            ;;
;;                                                                               ;;
;;  Will align a block to a CurveObject [Arc,Line,Polyline,Ellipse,etc], with    ;;
;;  controllable offset and perpendicularity.                                    ;;
;;                                                                               ;;
;;  User is prompted for block specification, block will be inserted if not      ;;
;;  selected. User can also specify whether block should be rotated to suit      ;;
;;  readability.                                                                 ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  FUNCTION SYNTAX:  BA                                                         ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  AUTHOR:                                                                      ;;
;;                                                                               ;;
;;  Copyright © Lee McDonnell, April 2010. All Rights Reserved.                  ;;
;;                                                                               ;;
;;      { Contact: Lee Mac @ TheSwamp.org, CADTutor.net }                        ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  VERSION:                                                                     ;;
;;                                                                               ;;
;;  ø 1.0   ~¤~    29th April 2010   ~¤~   º First Release                       ;;
;;...............................................................................;;
;;  ø 1.1   ~¤~    30th April 2010   ~¤~   º Added Scale option                  ;;
;;...............................................................................;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;

(defun c:ba nil (c:BLK_Align))

(defun c:BLK_Align ( / *error* B! BBOX CURV DOC LLST OBJ OLDPOS OLDROT SEL SPC )
  (vl-load-com)
  ;; Lee Mac  ~  29.04.10

  (defun *error* ( msg )
    (and lLst   (LayerRestore lLst))
    (and OldPos (vla-put-insertionPoint obj OldPos))
    (and OldRot (vla-put-Rotation obj OldRot))
    (and b!     (not (vlax-erased-p Obj))
      (vl-catch-all-apply
        (function vla-delete) (list obj)
      )
    )
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )
           

  (setq spc  (if (or (eq AcModelSpace (vla-get-ActiveSpace
                                        (setq doc (vla-get-ActiveDocument
                                                    (vlax-get-acad-object)))))
                     
                     (eq :vlax-true   (vla-get-MSpace doc)))
               
               (vla-get-ModelSpace doc)
               (vla-get-PaperSpace doc))

        lLst (LayerUnlock))

  (while
    (progn
      (setq Sel
        (SelectionOrText
          (strcat "\nSpecify Block to Align"
            (if (eq "" (getvar 'INSNAME)) ": "
              (strcat " <" (getvar 'INSNAME) "> : ")
            )
          )
          2
        )
      )
      (cond
        (
          (vl-consp sel)

          (if (not (= 4 (length sel)))
            (princ "\n** Invalid Object Selected **")
            (not
              (setq obj
                (vlax-ename->vla-object
                  (car
                    (last sel)
                  )
                )
              )
            )
          )
        )
        (
          (eq 'STR (type sel))

          (if (eq "" sel) (setq sel (getvar 'INSNAME)))

          (if (not (or (tblsearch "BLOCK" sel)
                       (setq sel (findfile (strcat sel ".dwg")))))
            
            (princ "\n** Block not Found **")
            (if
              (and
                (setq scl
                  (cond
                    (
                      (getreal "\nSpecify Block Scale <1.0> : ")
                    )
                    (
                      1.0
                    )
                  )
                )                    
                (not
                  (vl-catch-all-error-p
                    (setq Obj
                      (vl-catch-all-apply (function vla-InsertBlock)
                        (list spc (vlax-3D-point (getvar 'VIEWCTR)) sel scl scl scl 0.)
                      )
                    )
                  )
                )
              )
              (progn
                (setvar 'INSNAME (vl-filename-base sel))
                (not
                  (setq b!
                    (not
                      (vla-put-Visible Obj :vlax-false)
                    )
                  )
                )                
              )
              (princ "\n** Error Inserting Block **")
            )
          )
        )
      )
    )
  )
 
  (if
    (and Obj
      (setq Curv
        (CurveIfFoo isCurveObject "\nSelect Curve: ")
      )
    )
    (progn
      (initget "Yes No")
      (setq Red (not (eq "No" (getkword "\nMake Block Readable? [Y/N] <Yes> : "))))
      
      (setq bbox (GetBoundingBox Obj))
      (or  b! (and (setq OldPos (vla-get-InsertionPoint Obj))
                   (setq OldRot (vla-get-Rotation Obj))))
      (and b! (vla-put-Visible Obj :vlax-true))

      (setq b!
        (not
          (AlignObjtoCurve Obj Curv
            (/ (- (cadadr bbox) (cadar bbox)) 2.) Red
          )
        )
      )
    )
  )

  (LayerRestore lLst)

  (princ)
)   
       

(defun isCurveObject ( ent )
  (not
    (vl-catch-all-error-p
      (vl-catch-all-apply
        (function vlax-curve-getEndParam) (list ent)))))


(defun GetBoundingBox ( obj / ll ur )
  (if (vlax-method-applicable-p obj 'GetBoundingBox)
    (progn
      (vla-getBoundingBox obj 'll 'ur)

      (mapcar (function vlax-safearray->list) (list ll ur))
    )
  )
)  


(defun CurveifFoo ( foo str / sel ent )
  (while
    (progn
      (setq sel (entsel str))
      
      (cond (  (vl-consp sel)

               (if (not (foo (setq ent (car sel))))
                 (princ "\n** Invalid Object Selected **"))))))
  ent)


(defun SelectionOrText ( str cur )
  (and str (princ str))
  (
    (lambda ( result / gr code data )  
      (while
        (progn
          (setq gr (grread t 13 cur) code (car gr) data (cadr gr))

          (cond
            (
              (and (= 3 code) (listp data))

              (setq result (nentselp data)) nil
            )
            (
              (= 2 code)

              (cond
                (
                  (<= 32 data 126)

                  (setq result (strcat result (princ (chr data))))
                )
                (
                  (= 13 data) nil
                )
                (
                  (and (= 8 data) (< 0 (strlen result)))

                  (setq result (substr result 1 (1- (strlen result))))
                  (princ (vl-list->string '(8 32 8)))
                )
                (
                  t
                )
              )
            )
            (
              (= 25 code) nil
            )
            (
              t
            )
          )
        )
      )
      result
    )
    ""
  )
)

(defun AlignObjToCurve ( obj ent o r / msg gr code data pt cAng lAng )
 
  (or *Mac$Per* (setq *Mac$Per* (/ pi 2.)))
  (or *Mac$Off* (setq *Mac$Off* 1.))

  (setq msg  (princ "\n[+/-] for offset, [P]erpendicularity toggle, <Exit>"))
 
  (while
    (progn
      (setq gr (grread 't 15 0) code (car gr) data (cadr gr))
      
      (cond
        (
          (and (= 5 code) (listp data))
          (setq data (trans data 1 0))

          (setq pt   (vlax-curve-getClosestPointto ent data)
                cAng (angle pt data)
                lAng (+ cAng *Mac$Per*))
         
          (and R (setq lAng (MakeReadable lAng)))

          ;;(vla-put-InsertionPoint Obj
          ;;  (vlax-3D-point
          ;;    (polar pt cAng (* o *Mac$Off*))
          ;;  )
          ;;)
          (vla-put-Rotation Obj lAng)
 
          t
        )
        (
          (= 2 code)

          (cond
            (
              (vl-position data '(43 61))

              (setq *Mac$Off* (+ *Mac$Off* 0.1))
            )
            (
              (= 45 data)

              (setq *Mac$Off* (- *Mac$Off* 0.1))
            )
            (
              (vl-position data '(80 112))

              (setq *Mac$Per* (- (/ pi 2.) *Mac$Per*))
            )
            (
              (vl-position data '(13 32))

              nil
            )
            (
              t
            )
          )
        )
        (
          (and (= 3 code) (listp data))
          (setq data (trans data 1 0))

          (setq pt   (vlax-curve-getClosestPointto ent data)
                cAng (angle pt data)
                lAng (+ cAng *Mac$Per*))

          (and R (setq lAng (MakeReadable lAng)))

          ;;(vla-put-InsertionPoint Obj
          ;;  (vlax-3D-point
          ;;    (polar pt cAng (* o *Mac$Off*))
          ;;  )
          ;;)
          (vla-put-Rotation Obj lAng)

          nil
        )
        (
          (= 25 code)

          nil
        )
        (
          t
        )
      )
    )
  )
  data
)


(defun MakeReadable ( a )
  (cond
    (
      (and (> a (/ pi 2)) (<= a pi))

      (- a pi)
    )
    (
      (and (> a pi) (<= a (/ (* 3 pi) 2)))

      (+ a pi)
    )
    (
      a
    )
  )
)

(defun LayerUnlock ( / lock )
  (vlax-for layer
    (vla-get-Layers
      (vla-get-ActiveDocument
        (vlax-get-acad-object)
      )
    )
    (if (eq :vlax-true (vla-get-Lock layer))
      (progn
        (setq lock (cons layer lock))
        (vla-put-lock layer :vlax-false)
      )
    )
  )
  lock
)

(defun LayerRestore ( lst )
  (mapcar
    (function
      (lambda ( layer )
        (vla-put-lock layer :vlax-true)
      )
    )
    lst
  )
)
                  
(princ "\nø¤º°`°º¤ø  BAlign.lsp ~ Copyright © by Lee McDonnell  ø¤º°`°º¤ø")
(princ "\n   ~¤~      ...Type \"BLK_Align\" or \"BA\" to Invoke...        ~¤~   ")
(princ)

;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;                                                                               ;;
;;                             End of Program Code                               ;;
;;                                                                               ;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;

[ishka]

Looks like I need to clean it a little bit, since I don't need the +- offset. Is it easy to add a mirror option for the block once it is readable? So if I want to flip it 180 degrees after I applied the readable or not, can that one be integrated in the code? I think I need to define the mirror as a new function in the same way as the Make Readable, and so on, Otherwise I guess I will need after the block looks at some rotation I want, to use something like the following to flip it.

 

(defun c:BLK_Flip ( / SelSet Counter EntName Obj )
  (princ "Command: Rotate selected Blocks 180 degrees " )
  (if (setq SelSet (ssget '((0 . "INSERT" ))) )
    (progn
      (setq Counter 0 )
      (vl-load-com)
      (while (setq EntName (ssname SelSet Counter ))
        (setq Obj (vlax-ename->vla-Object EntName ) )
        (vlax-put-property Obj "Rotation" (+ (vlax-get Obj "Rotation" ) pi ) )
        (vlax-release-Object Obj )
        (setq Counter (1+ Counter ) )
      )
    )
    (princ ". . no Block selected ! " )
  )
  (princ)
)

 

I try to integrate the mirror of make readable output inside the first routine, so I don't need to use two separate lsp files. I am not a big coder, but understanding the thinking about the language, I try to combine and make stuff happen.

[ishka]

Can the routine be updated to apply to a COGO point for Civil 3D? If we need to align a COGO point to a linear object, polyline, feature line or survey figure but without moving the location, just applying the rotation to the marker of the COGO point, then it could speed up the process of making COGO points estethically aligning with the linework.