alanjt's Misc. Useful Lisp Routines

[alanjt]

;join multiple lines/arcs
;created: alan thompson, 4.23.08
;modified: alan thompson, 5.13.08 (localized variables to stop being so sloppy)
(defun c:mj(/ lines)
(princ "\nSelect lines & arcs to JOIN: ")
(setq lines (ssget ":L" '((0 . "LINE,*POLYLINE,ARC"))))
(if lines
 (progn
  (if 
   (equal (getvar 'peditaccept) 1)
     (vl-cmdf "_.pedit" "_m" lines "" "_j" "" "")
     (vl-cmdf "_.pedit" "_m" lines "" "_y" "_j" "" "")
  );if
 );progn
 (alert (strcat "\nHey " (getvar "loginname") " it helps if you actually select something to work with!"))
);if
(princ)
);defun

[alanjt]

;rotate selected objects 180°
;Alan J. Thompson
(defun c:RR ( / obj pnt )
(if
 (and
  (princ "\nSelect object(s) to rotate 180°: ")
  (setq obj (ssget ":L"))
  (setq pnt (getpoint "\nPick rotation base point: "))
 );and
   (progn
    (command "_.rotate" obj "" "_non" pnt "180")
    (princ (strcat "\n " (rtos (sslength obj) 2 0) " object(s) have been rotated 180°"))
   );progn
   (princ "\nMissed, try again.")
);if
(princ)
);defun

[alanjt]

;turn on and thaw all layers
(defun c:SEE ()
(command "-layer" "thaw" "*" "on" "*" "" )
(princ (strcat "\nALL LAYERS HAVE BEEN THAWED AND TURNED ON."))
(princ))

[alanjt]

;text & leader delete
;only selects text, mtext & leaders to erase
;created: alan thompson - 4.17.08
(defun c:TX (/ ss)
 (prompt "\nSelect text & leaders to erase: ")
 (setq ss (ssget '((0 . "TEXT,MTEXT,LEADER"))))
(if ss
 (progn
   (command "erase" ss "" )
   (princ (strcat "\n " (rtos (sslength ss)) " Text and/or Leader objects have been deleted."))
 );progn
 (princ "\nNo text selected, try again.")
);if
 (princ)
)

[alanjt]

;zoom to specific scale
(mapcar
 '(lambda (f z)
    (eval (list 'defun
        f
        nil
        (list 'command "_.zoom" (strcat "1/" (itoa z) "xp"))
        (list 'princ (strcat "\nZoomed Scale: 1\" = " (itoa z) "'") )
        '(princ)
      )
    )
  )
 '(c:10 c:20 c:30 c:40 c:50 c:60 c:100 c:200 c:300 c:400 c:500 c:600 c:1000 c:2000 c:3000 c:4000 c:5000 c:6000)
 '(10 20 30 40 50 60 100 200 300 400 500 600 1000 2000 3000 4000 5000 6000)
)

[alanjt]

; Current Layer Set and/or Reset

; created by: alan thompson, 2.24.09

(defun c:LRS ( / )
(if
 (setq $LRS=Clayer$ (getvar "clayer"))
  (princ (strcat "\n \"" $LRS=Clayer$ "\" is the stored revert layer."))
);if
(princ)
);defun


(defun c:LR ( / )
(if
 (and
  $LRS=Clayer$
  (tblsearch "layer" $LRS=Clayer$)
 );and
;t, let's set it as our current layer
   (progn
    (vl-cmdf "_.layer" "_t" $LRS=Clayer$ "_s" $LRS=Clayer$ "")
    (princ (strcat "\n \"" $LRS=Clayer$ "\" is the current layer."))
   );progn
;nil, let's store a different layer (run c:LRS)
   (progn
    (princ "\nStored layer nil, resetting...")
    (if c:LRS
     (c:LRS)
     (alert "Command \"c:LRS\" is not loaded.")
    );
   );progn
);if
(princ)
);defun

[flowerrobot]

Mate nice work..

 

Purhaps a Zip file following would be grand aswell, Saves the hole copy & pasting them

 

Flower

[alanjt]

Mate nice work..

 

Purhaps a Zip file following would be grand aswell, Saves the hole copy & pasting them

 

Flower

Ehh, then how would I fluff my post count.:wink:

It's just a bunch of random stuff, I figured people could read through them (if they wanted) and take what they like.

Judging by the response, they're of no use anyway. Oh well, not why I posted them.

[mdbdesign]

Ehh, then how would I fluff my post count.:wink:

Look like counter get stuck...

[The Buzzard]

Ehh, then how would I fluff my post count.:wink:

It's just a bunch of random stuff, I figured people could read through them (if they wanted) and take what they like.

Judging by the response, they're of no use anyway. Oh well, not why I posted them.

 

Alan,

 

It looks like a Lisp Clearence Sale.

 

Everything Must Go!

[alanjt]

Alan,

 

It looks like a Lisp Clearence Sale.

 

Everything Must Go!

 

LoL

I just thought I'd post some randoms. No sense in them sitting in my LSP folder, only being used by me. If someone else can benefit from it, why not share it.

I wrote them because I felt they were a useful addition to AutoCAD, someone out there might feel the same.

[alanjt]

;toggle toolpalettes on/off state
(defun c:TP()
(if
   (equal (getvar 'tpstate) 0)
   (command "'toolpalettes")
   (command "'toolpalettesclose")
);if
(princ))


;toggles properties menu on/off state
(defun c:MO()
(if
   (equal (getvar 'opmstate) 2)
   (princ "\nNo toggle for you!")
   (progn
   (if
       (equal (getvar 'opmstate) 0)
       (command "'properties")
       (command "'propertiesclose")
   );if
   );progn
);if
(princ))


;toggle layer properties manager on/off state
(defun c:LY()
(if
   (equal (getvar 'layermanagerstate) 0)
   (progn
       (initdia)
       (command "'layer")
   );progn
   (command "layerclose")
);if
(princ))


;toggle sheet set manager on/off state
(defun c:SSM ()
(if
   (equal (getvar 'ssmstate) 0)
   (command "sheetset")
   (command "'sheetsethide")
);if
(princ))

[alanjt]

;toggle between ucs world and previous ucs (if "A" exists, it will be set as current)
(defun c:UT()
(if
   (equal (getvar 'worlducs) 1)
       (progn
           (if (tblsearch "ucs" "a")
               (command "ucs" "r" "a")
               (command "ucs" "p")
           );if
       );progn
       (command "ucs" "world")
);if
(princ))



;toggle between tilemodes/spaces (paper/model)
(defun c:TI (/)
(setvar 'tilemode (abs (1- (getvar 'tilemode))))
(princ)
)

[alanjt]

;toggle on/off state of the current layer
;created by: alan thompson  6.13.08
(defun c:tg (/ layer_info layer_color)
   (setq layer_info (entget (tblobjname "LAYER" (getvar 'clayer))))
   (setq layer_color (assoc 62 layer_info))
   (entmod (subst (cons 62 (- (cdr layer_color))) layer_color layer_info))
   (princ (strcat "\nLayer * " (getvar "clayer") " * has been turned "
           (if
               (< (cdr layer_color) 0
               )
               "on!"
               "off!"
           );if
       );strcat
   );princ
(princ))

[alanjt]

;rotate objects (created for rotating lines) to match a rotation of another line based on the 2 end points
;created by: alan thompson, 2.14.08 (Valentine's Day)
(defun c:RF ( / obj base_pnt obj_pnt )
(princ "\nSelect object(s) to rotate: ")
(if
 (and
  (setq obj (ssget ":L"))
  (setq base_pnt (getpoint "\nSpecify base point: "))
  (setq obj_pnt (getpoint base_pnt "\nPick point of object to rotate: "))
 );and
   (command "_.rotate" obj "" "_non" base_pnt "_r" "_non" base_pnt "_non" obj_pnt)
   (princ "\nMissed, try again.")
);if
(princ)
);defun

[alanjt]

;;; Check if 2 lines are parallel
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 09.08.09
(defun c:PL (/ #Line1 #Line2 #Angle1 #Angle2)
 (cond
   ((and (setq #Line1 (AT:Entsel T
                                 "\nSpecify first line: "
                                 '((0 . "LINE"))
                                 nil
                      ) ;_ AT:Entsel
         ) ;_ setq
         (setq #Line2 (AT:Entsel T
                                 "\nSpecify second line: "
                                 '((0 . "LINE"))
                                 nil
                      ) ;_ AT:Entsel
         ) ;_ setq
    ) ;_ and
    (setq #Line1  (entget (car #Line1))
          #Line2  (entget (car #Line2))
          #Angle1 (angle (cdr (assoc 10 #Line1)) (cdr (assoc 11 #Line1)))
          #Angle2 (angle (cdr (assoc 10 #Line2)) (cdr (assoc 11 #Line2)))
    ) ;_ setq
    (princ (strcat "\nSelected lines"
                   (if (or (equal #Angle1 #Angle2 0.000001)
                           (equal #Angle1 (+ pi #Angle2) 0.000001)
                           (equal (+ pi #Angle1) #Angle2 0.000001)
                       ) ;_ or
                     " ARE "
                     " are NOT "
                   ) ;_ if
                   "parallel!"
           ) ;_ strcat
    ) ;_ princ
   )
 ) ;_ cond
 (princ)
) ;_ defun

[alanjt]

;;; Change color of selected objects' layer
;;; Required Subroutines: AT:SS->List
;;; Alan J. Thompson, 07.23.09
(defun c:CLC (/ #SSList #Color)
 (and
   (setq #SSList (AT:SS->List (ssget) T))
   (setq #Color (acad_colordlg 1))
   (foreach x #SSList
     (vla-put-color
       (vlax-ename->vla-object
         (tblobjname
           "layer"
           (vla-get-layer x)
         ) ;_ tblobjname
       ) ;_ vlax-ename->vla-object
       #Color
     ) ;_ vla-put-color
   ) ;_ foreach
 ) ;_ and
 (princ)
) ;_ defun

[flowerrobot]

I figured people could read through them (if they wanted) and take what they like.

Judging by the response, they're of no use anyway. Oh well, not why I posted them.

 

Not sure if people do take use of things and not say they did, Or People dont.. There was a couple that would save some time, But there were some good snickets that would be usefull

[alanjt]

Not sure if people do take use of things and not say they did, Or People dont.. There was a couple that would save some time, But there were some good snickets that would be usefull

Oh I know. My purpose in posting these was not for a response. Like I said, I use them and I thought they might benefit someone else.

[flowerrobot]

might benefit someone else.

Might benefit the lasy who dont have the time to copy them, With a zip file