Jump to content

Object Align with dcl

exceed

By exceed
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

exceed Proficient

exceed

Posted
Posted 
; Object Align - 2022.05.04 exceed

(vl-load-com)
(defun c:OA ( / util mode answer p s sl index ename obj box lll url basept targetpt ahbuttstitle ahbuttslst1 ahbuttslst2 pickmode modetxt answerlist originobj originbox olll ourl oll our )

  (LM:startundo (LM:acdoc))
  (setvar "cmdecho" 0)
  (setq util (vla-get-utility (LM:acdoc)))

  ;error control
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\n Error: " msg))
        )
        (setvar "cmdecho" 1)
        (princ)
    )

  (defun AH:Butts (ahdef ahbuttstitle ahbuttslst1 ahbuttslst2 / fo fname x k but1 but2 )
    (setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w"))
    (write-line  "AHbutts : dialog 	{" fo)
    (write-line  (strcat "	label =" (chr 34) (vl-princ-to-string ahbuttstitle) (chr 34) " ;" )fo)

    (write-line "	: row	{" fo)

    (write-line "	: boxed_radio_column 	{" fo)
    (write-line (strcat "key = " (chr 34) (nth 0 ahbuttslst1) (chr 34) ";") fo)
    (write-line (strcat "label = " (chr 34) (nth 0 ahbuttslst1) (chr 34) ";") fo)
    (write-line  (strcat " width = " (rtos (+ 5 15) 2 0) " ;")  fo)		; increase 10 if label does not appear
    (setq x 1)
    (repeat (- (length ahbuttslst1) 1)
      (write-line "	: radio_button	{" fo)
      (write-line  (strcat "key = "  (chr 34) "Rba" (rtos x 2 0) (chr 34) ";") fo)
      (write-line  (strcat "label = " (chr 34) (nth x ahbuttslst1) (chr 34) ";") fo)
      (write-line "	}" fo)
      (setq x (+ x 1))
    )

    (write-line "spacer_1 ;" fo)
    (write-line "	}" fo)

    (write-line "	: boxed_radio_column 	{" fo)
    (write-line (strcat "key = " (chr 34) (nth 0 ahbuttslst2) (chr 34) ";") fo)
    (write-line (strcat "label = " (chr 34) (nth 0 ahbuttslst2) (chr 34) ";") fo)
    (write-line  (strcat " width = " (rtos (+ 5 15) 2 0) " ;")  fo)		; increase 10 if label does not appear
    (setq x 1)
    (repeat (- (length ahbuttslst2) 1)
      (write-line "	: radio_button	{" fo)
      (write-line  (strcat "key = "  (chr 34) "Rbb" (rtos x 2 0)  (chr 34) ";") fo)
      (write-line  (strcat "label = " (chr 34) (nth x ahbuttslst2) (chr 34) ";") fo)
      (write-line "	}" fo)
      (setq x (+ x 1))
    )

    (write-line "spacer_1 ;" fo)
    (write-line "	}" fo)

    (write-line "	}" fo)
    (write-line "spacer_1 ;" fo)
    (write-line "	ok_only;" fo)
    (write-line "	}" fo)

  (close fo)
  (setq dcl_id (load_dialog fname))
  (if (not (new_dialog "AHbutts" dcl_id) )
    (exit)
  )

  (setq but1 1)
  (setq but2 1)

  (setq x 1)
  (repeat (length ahbuttslst1)
    (setq k (strcat "Rba" (rtos x 2 0)))
    (action_tile k  (strcat "(setq but1 " (rtos x 2 0) ")"))
    (if (= ahdef x) (set_tile k "1"))
    (setq x (+ x 1))
  )

  (setq x 1)
  (repeat (length ahbuttslst2)
    (setq k (strcat "Rbb" (rtos x 2 0) ))
    (action_tile k  (strcat "(setq but2 " (rtos x 2 0) ")"))
    (if (= ahdef x) (set_tile k "1"))
    (setq x (+ x 1))
  )

  (set_tile "Rba1" "1")
  (set_tile "Rbb1" "1")

  (action_tile "accept" (strcat "(done_dialog)")) 

  (start_dialog)
  (unload_dialog dcl_id)
  (vl-file-delete fname)
 
  (list (nth but1 ahbuttslst1) (nth but2 ahbuttslst2))
)

  (setq ahbuttstitle "Object Align")
  (setq ahbuttslst1 (list "Align by" "Pick Point" "Select Object"))
  (setq ahbuttslst2 (list "Direction" "Left" "Right" "Up" "Down" "Horizontal Center" "Vertical Center"))

  (if (= ahdef nil)(setq ahdef 1))
  (setq answerlist (AH:Butts ahdef ahbuttstitle ahbuttslst1 ahbuttslst2))

  (setq pickmode (car answerlist))
  (setq modetxt (cadr answerlist))
  (cond 
    ((= modetxt "Left")
      (setq mode "L")
    )
    ((= modetxt "Right")
      (setq mode "R")
    )
    ((= modetxt "Up")
      (setq mode "U")
    )
    ((= modetxt "Down")
      (setq mode "D")
    )
    ((= modetxt "Horizontal Center")
      (setq mode "HC")
    )
    ((= modetxt "Vertical Center")
      (setq mode "VC")
    )
  )

  (cond 
    ((= pickmode "Pick Point")
      (princ "\n Select the objects to align : ")
      (setq s (ssget ":L"))
      (setq sl (sslength s))

      (setq p (getpoint "\n Pick reference point : ")) 
      (setq p (trans p 1 0))

      (cond 
        ((or (= mode "L") (= mode "R") (= mode "HC"))
          (setq p (car p))
        )
        ((or (= mode "U") (= mode "D") (= mode "VC"))
          (setq p (cadr p))
        )    
      );end of cond

      (setq index 0)
      (repeat sl
        (setq ename (ssname s index))
        (setq obj (vlax-ename->vla-object ename))
        (setq box (vla-getboundingbox obj 'll 'ur))
        (setq lll (vlax-safearray->list ll)) ; lower left point
        (setq url (vlax-safearray->list ur)) ; upper right point
        (cond 
          ((= mode "L")
            (setq basept lll)
            (setq targetpt (list p (cadr basept) (caddr basept)))
          )
          ((= mode "R")
            (setq basept url)
            (setq targetpt (list p (cadr basept) (caddr basept)))
          )
          ((= mode "HC")
            (setq basept (list (/ (+ (car lll) (car url)) 2) (/ (+ (cadr lll) (cadr url)) 2) (/ (+ (caddr lll) (caddr url)) 2)))
            (setq targetpt (list p (cadr basept) (caddr basept)))
          )
          ((= mode "U")
            (setq basept url)
            (setq targetpt (list (car basept) p (caddr basept)))
          )
          ((= mode "D")
            (setq basept lll)
            (setq targetpt (list (car basept) p (caddr basept)))
          )
          ((= mode "VC")
            (setq basept (list (/ (+ (car lll) (car url)) 2) (/ (+ (cadr lll) (cadr url)) 2) (/ (+ (caddr lll) (caddr url)) 2)))
            (setq targetpt (list (car basept) p (caddr basept)))
          )
        );end of cond 


        (vlax-invoke obj 'move basept targetpt )
        (setq index (+ index 1))
      ); end of repeat
    );end of cond case1 
    ((= pickmode "Select Object")
      (princ "\n Select the objects to align : ")
      (setq s (ssget ":L"))
      (setq sl (sslength s))

      (princ "\n Select a reference object : ")
      (setq originobj (vlax-ename->vla-object (car (entsel))))
      (setq originbox (vla-getboundingbox originobj 'oll 'our))
      (setq olll (vlax-safearray->list oll))
      (setq ourl (vlax-safearray->list our))

      (cond 
        ((= mode "L") 
          (setq p (car olll))
        )
        ((= mode "R") 
          (setq p (car ourl))
        )
        ((= mode "HC") 
          (setq p (/ (+ (car olll) (car ourl)) 2))
        )  
        ((= mode "U") 
          (setq p (cadr ourl))
        )
        ((= mode "D") 
          (setq p (cadr olll))
        )
        ((= mode "VC") 
          (setq p (/ (+ (cadr olll) (cadr ourl)) 2))
        )  
      );end of cond

      (setq index 0)
      (repeat sl
        (setq ename (ssname s index))
        (setq obj (vlax-ename->vla-object ename))
        (setq box (vla-getboundingbox obj 'll 'ur))
        (setq lll (vlax-safearray->list ll)) ; lower left point
        (setq url (vlax-safearray->list ur)) ; upper right point

        (cond 
          ((= mode "L")
            (setq basept lll)
            (setq targetpt (list p (cadr basept) (caddr basept)))
          )
          ((= mode "R")
            (setq basept url)
            (setq targetpt (list p (cadr basept) (caddr basept)))
          )
          ((= mode "HC")
            (setq basept (list (/ (+ (car lll) (car url)) 2) (/ (+ (cadr lll) (cadr url)) 2) (/ (+ (caddr lll) (caddr url)) 2)))
            (setq targetpt (list p (cadr basept) (caddr basept)))
          )
          ((= mode "U")
            (setq basept url)
            (setq targetpt (list (car basept) p (caddr basept)))
          )
          ((= mode "D")
            (setq basept lll)
            (setq targetpt (list (car basept) p (caddr basept)))
          )
          ((= mode "VC")
            (setq basept (list (/ (+ (car lll) (car url)) 2) (/ (+ (cadr lll) (cadr url)) 2) (/ (+ (caddr lll) (caddr url)) 2)))
            (setq targetpt (list (car basept) p (caddr basept)))
          )

        );end of cond 

        (vlax-invoke obj 'move basept targetpt)
        (setq index (+ index 1))
      );end of repeat
    );end of cond case2
  );end of cond



  (setvar "cmdecho" 1)
  (LM:endundo (LM:acdoc))
  (princ)
);end of defun


;; 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)
)


;; 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)
    )
)

2022-05-04%2016;34;14.gif

 

2022-05-04%2016;33;19.PNG

 

 

today, I practiced DCL. Most of this code is by BIGAL's Radio Button code. Thanks to him.

after disassembling it like this, I think I know how to make dcl a little bit.

and then create a bounding box and move it.

 

aligns the selected objects like MS Office's Align function. 

I can't figure out why CAD's default align command is like 'piping join'. I think there must be a reason...

 

command : OA (Object Align)

- select the objects before or after run this

- support UCS not only WCS (maybe..)

 

 

If there are other good Lisp that do this, please let me know. It helps me with my studies.

 

 

 

  • Like 3
Link to comment
Share on other sites
Isaac26a Collaborator

Isaac26a

Posted
Posted
9 hours ago, exceed said:

command : OA (Object Align)

- select the objects before or after run this

- support UCS not only WCS (maybe..)

Thanks for sharing this lisp, i was thinking in doing something similar but much more simpler, I'll study it and use it. Thanks again. :beer:

  • Like 1
Link to comment
Share on other sites
BIGAL Grand Master

BIGAL

Posted
Posted (edited)

Glad to see the 2 column radio buttons was useful.

 

You dont need the dcl code in your code you can just have it as a lisp and use (if (not AH:Butts)(Load "Multi radio 2col.lsp")) you just have to have the lisp in a support directory or use full path in the (load "C:\\mylisp files\\Multi radio buttons 2col.lsp")

 

I need to add a Cancel button. Maybe version 3 which will be multi columns, 1 to how ever many.

Edited by BIGAL
  • Like 1
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...