alanjt's Misc. Useful Lisp Routines

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

If they are too lazy to read through them, post by post, they are going to be too lazy to look through them if zipped.

I looked threw all of them , But was to lasy to copy them, I spose there not going any where?

I looked threw all of them , But was to lasy to copy them, I spose there not going any where?

That's what you think.

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.

}

This is actually what I did... some of them will help me to come up with new stuff in my standards...

Very nice post.

}

 

This is actually what I did... some of them will help me to come up with new stuff in my standards...

 

Very nice post.

Hope something helps.

Needed something like this today so I rolled my own, real quick.

It's silly, but saved me a lot of time not having to open lots of text objects.

;;; Text Stack/Compress Contents
;;; Alan J. Thompson, 10.21.09
(defun c:TSC (/ #Choice #SS #String #Find #Replace)
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (initget 0 "Compress Stack")
 (cond
   ((and (or (setq #Choice (getkword "\nText content change options [Compress/Stack] <Compress>: "))
             (setq #Choice "Compress")
         ) ;_ or
         (setq #SS (ssget "_:L" '((0 . "MTEXT,TEXT,MULTILEADER"))))
    ) ;_ and
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (setq #String (vla-get-TextString x))
      (if (eq #Choice "Compress")
        (setq #Find "\\P"
              #Replace " "
        ) ;_ setq
        (setq #Find " "
              #Replace "\\P"
        ) ;_ setq
      ) ;_ if
      (while (vl-string-search #Find #String)
        (setq #String (vl-string-subst #Replace #Find #String))
      ) ;_ while
      (vla-put-TextString x #String)
    ) ;_ vlax-for
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

Drawing in a city aerial map today and all centerline intersections were given in coordinates. I didn't feel like typing in Easting,Northing, mostly because I kept flipping them. It's nothing special, but it kept my head on straight and I thought I'd share.

;;; Paste Point Info. To Commandline (intended for transparent execution)
;;; Alan J. Thompson, 10.27.09
(defun c:PP (/ #North #East #Elev #Val)
 (and (setq #North (getreal "\nNorthing: "))
      (setq #East (getreal "\nEasting: "))
      (or (setq #Elev (getreal "\nElevation <0.0>: ")) (setq #Elev 0.0))
      (setq #Val (mapcar '(lambda (x) (rtos x (getvar 'lunits) 4)) (list #North #East #Elev)))
      (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
      (vla-sendcommand *AcadDoc* (strcat "_non " (cadr #Val) "," (car #Val) "," (last #Val) " "))
 ) ;_ and
 (princ)
) ;_ defun

Example of it being called within line command:

Command: L LINE Specify first point: 'PP
Northing: 1991653

Easting: 12710.9

Elevation <0.0>:
Specify first point: Specify first point: _non 12710.9,1991653,0
Specify next point or [undo]:
Specify next point or [undo]:

;;; Quick Area, based on picked point inside closed area
;;; Alan J. Thompson, 10.29.09
(defun c:QA (/ #Entlast #Pnt #Ent #Area)
 (and (or *Acad* (setq *Acad* (vlax-get-acad-object)))
      (or (setq #Entlast (entlast)) (setq #Entlast T))
      (setq #Pnt (getpoint "\nSpecify internal point: "))
      (not (vla-zoomextents *Acad*))
      (vl-cmdf "_.-boundary" "_a" "_i" "_n" "" "" #Pnt "")
      (not (vla-zoomprevious *Acad*))
      (not (eq #Entlast (setq #Ent (entlast))))
      (setq #Area (vla-get-area (vlax-ename->vla-object #Ent)))
      (entdel #Ent)
      (princ (strcat "\nSq. Ft.: "
                     (rtos #Area 2 3)
                     "\nAcres:  "
                     (rtos (/ #Area 43560.) 2 3)
             ) ;_ strcat
      ) ;_ princ
 ) ;_ and
 (princ)
) ;_ defun

;;; Filtered Selection (Block Name, Entity Type, Layer)
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 11.03.09
(defun c:FT (/ #Choice #Num #Ent #Filter #SS)
 (initget 0 "Block Entity Layer")
 (and
   (or (setq
         #Choice (getkword
                   "\nFilter by (B)lock Name, (E)ntity Type or (L)ayer? [block/Entity/<Layer>]: "
                 ) ;_ getkword
       ) ;_ setq
       (setq #Choice "Layer")
   ) ;_ or
   (cond
     ((eq #Choice "Block")
      (setq #Num 2)
      (if (setq #Ent (AT:Entsel nil "\nSelect block for name: " '((0 . "INSERT")) nil))
        (princ
          (strcat "\nBlock: \"" (setq #Filter (cdr (assoc 2 (entget (car #Ent))))) "\" selected.")
        ) ;_ princ
      ) ;_ if
     )
     ((eq #Choice "Entity")
      (setq #Num 0)
      (if (setq #Ent (AT:Entsel nil "\nSelect object for entity type: " nil nil))
        (princ (strcat "\n\"" (setq #Filter (cdr (assoc 0 (entget (car #Ent))))) "\" selected."))
      ) ;_ if
     )
     ((eq #Choice "Layer")
      (setq #Num 
      (if (setq #Ent (AT:Entsel nil "\nSelect object for layer: " nil nil))
        (princ (strcat "\nObject on layer: \""
                       (setq #Filter (cdr (assoc 8 (entget (car #Ent)))))
                       "\" selected."
               ) ;_ strcat
        ) ;_ princ
      ) ;_ if
     )
   ) ;_ cond
   (setq #SS (ssget (list (cons #Num #Filter))))
   (sssetfirst nil #SS)
   (princ (strcat "\n" (itoa (sslength #SS)) " object(s) selected."))
 ) ;_ and
 (princ)
) ;_ defun

;;; Change width of selected MText and MultiLeader objects
;;; Alan J. Thompson, 11.05.09
(defun c:WD (/ #SS #Width)
 (cond
   ((and (setq #SS (ssget "_:L" '((0 . "MTEXT,MULTILEADER"))))
         (not (initget 4))
         (or (setq #Width (getdist "\nWidth <0.0>: ")) (setq #Width 0.))
    ) ;_ and
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (cond
        ((eq (vla-get-objectname x) "AcDbMText")
         (vl-catch-all-apply 'vla-put-width (list x #Width))
        )
        ((eq (vla-get-objectname x) "AcDbMLeader")
         (vl-catch-all-apply 'vla-put-textwidth (list x #Width))
        )
      ) ;_ cond
    ) ;_ vlax-for
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

;;; Restack bearing (toggle between "  " & "\\P")
;;; Alan J. Thompson, 11.10.09
(defun c:RS (/ #SS #Str)
 (cond
   ((setq #SS (ssget "_:L" '((0 . "MTEXT,MULTILEADER"))))
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (setq #Str (vla-get-textstring x))
      (cond
        ((vl-string-search "  " #Str) (setq #Str (vl-string-subst "\\P" "  " #Str)))
        ((vl-string-search "\\P" #Str) (setq #Str (vl-string-subst "  " "\\P" #Str)))
      ) ;_ cond
      (vla-put-textstring x #Str)
    ) ;_ vlax-for
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

;;; Draw Parallel Line, based on selected *line segment
;;; Required Subroutines: AT:Entsel, AT:Segment
;;; Alan J. Thompson, 11.10.09
(defun c:Par (/ #Ent #Pnt #Ang)
 (and (setq #Ent (AT:Entsel T "\nSelect object for angle: " '((0 . "*POLYLINE,LINE,AECC_PARCEL_SEGMENT")) nil))
      (setq #Pnt (getpoint "\nSpecify starting point: "))
      (setq
        #Ang (* 180.
                (/ (apply 'angle (mapcar '(lambda (x) (trans x 0 1)) (cadr (AT:Segment #Ent)))) pi)
             ) ;_ *
      ) ;_ setq
      (vl-cmdf "_.line" "_non" #Pnt (strcat "<" (rtos #Ang 2 16)) PAUSE)
 ) ;_ and
 (princ)
) ;_ defun

Cadtutor went down while I was posting all of this today. I hope I wasn't the culprit.

;;; Draw Perpendicular Line, based on selected *line segment
;;; Required Subroutines: AT:Entsel, AT:Segment, AT:ClosestEndPoint (AT:DrawX optional)
;;; Alan J. Thompson, 11.10.09
(defun c:Per (/ #Ent #Pnt #Ang)
 (and (setq #Ent (AT:Entsel T "\nSelect object for angle: " '((0 . "*POLYLINE,LINE,AECC_PARCEL_SEGMENT")) nil))
      (not (initget 0 "End Selection"))
      (or (setq #Pnt (getpoint "\nSpecify starting point [End/<Selection>]: "))
          (setq #Pnt "Selection")
      ) ;_ or
      (cond
        ((vl-consp #Pnt) T)
        ((eq #Pnt "Selection")
         (setq #Pnt (trans (vlax-curve-GetClosestPointTo (car #Ent) (trans (cadr #Ent) 1 0)) 0 1))
        )
        ((eq #Pnt "End") (setq #Pnt (trans (AT:ClosestEndPoint #Ent) 0 1)))
      ) ;_ cond
      (setq #Ang
             (+ 90.
                (* 180.
                   (/ (apply 'angle (mapcar '(lambda (x) (trans x 0 1)) (cadr (AT:Segment #Ent)))) pi)
                ) ;_ *
             ) ;_ +
      ) ;_ setq
      (if AT:DrawX (AT:DrawX #Pnt 1) T)
      (vl-cmdf "_.line" "_non" #Pnt (strcat "<" (rtos #Ang 2 16)) PAUSE)
 ) ;_ and
 (redraw)
 (princ)
) ;_ defun

;;; Divide objects along line/arc
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 11.10.09
(defun c:DAC (/ *error* #Flag #SS #Pnt #Obj #Num #Dist #Len)
 (setq *error* (lambda (x)
                 (and #Flag (vl-cmdf "_.ucs" "_p"))
                 (and *AcadDoc* (vla-endundomark *AcadDoc*))
               ) ;_ lambda
 ) ;_ setq
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark *AcadDoc*)
 (and (zerop (getvar 'worlducs)) (setq #Flag (vl-cmdf "_.ucs" "")))
 (and
   (princ "\nSelect object(s) to divide along curve: ")
   (setq #SS (ssget "_:L"))
   (setq #Pnt (getpoint "\nBase point for objects: "))
   (setq #Obj (AT:Entsel T "\nSelect curve to divide: " '("V" (0 . "LINE,*POLYLINE,ARC")) nil))
   (not (initget 6))
   (setq #Num (getint "\nNumber of objects: "))
   (setq #Dist 0.)
   (or (not (vl-catch-all-error-p (setq #Len (vl-catch-all-apply 'vla-get-length (list #Obj)))))
       (not (vl-catch-all-error-p (setq #Len (vl-catch-all-apply 'vla-get-arclength (list #Obj)))))
   ) ;_ or
   (while (<= #Dist (- #Len (/ #Len #Num)))
     (vl-cmdf "_.copy"
              #SS
              ""
              "_non"
              #Pnt
              "_non"
              (vlax-curve-getpointatdist #Obj (setq #Dist (+ #Dist (/ #Len #Num))))
     ) ;_ vl-cmdf
   ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; Line Match Draw
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 11.18.09
(defun c:LMD (/ *error* #Clayer #Obj)
 (setq *error* (lambda (x) (and #Clayer (setvar 'clayer #Clayer)) (setvar 'celtype "BYLAYER")))
 (setq #Clayer (getvar 'clayer))
 (or (setq #Obj (ssget "_I" '((0 . "ARC,CIRCLE,LINE,*POLYLINE")))) T)
 (and (or (and #Obj (setq #Obj (vlax-ename->vla-object (ssname #Obj 0))))
          (setq #Obj (AT:Entsel nil nil '("V" (0 . "ARC,CIRCLE,LINE,*POLYLINE")) nil))
      ) ;_ or
      (setvar 'clayer (vla-get-layer #Obj))
      (vl-catch-all-apply 'setvar (list 'celtype (vla-get-linetype #Obj)))
      (vl-cmdf "_.line")
      (while (> (getvar 'cmdactive) 0)
        (princ "\nSpecify point: ")
        (vl-cmdf PAUSE)
      ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; Draw line perpendicular from selected curve
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 09.29.09
(defun c:LPer (/ *error* #Ent #Obj #Point)
 (setq *error* (lambda (x) (and #Obj (vl-catch-all-apply 'vla-highlight (list #Obj :vlax-false)))))
 (and
   (setq #Ent (AT:Entsel nil "\nSelect curve: " '((0 . "*POLYLINE,ARC,LINE,CIRCLE,ELLIPSE")) nil))
   (setq #Obj (vlax-ename->vla-object (car #Ent)))
   (not (vla-highlight #Obj :vlax-true))
   (while (setq #Point (getpoint "\nSpecify point for line: "))
     (entmake (list '(0 . "LINE")
                    (cons 10 (vlax-curve-getclosestpointtoprojection (car #Ent) (trans #Point 1 0) '(0 0 1)))
                    (cons 11 (trans #Point 1 0))
              ) ;_ list
     ) ;_ entmake
   ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; LayerObjectSelect
;;; Select all objects on selected layers, in current layout
;;; Required Subroutines: AT:ListSelect, AT:TabFilter
;;; Alan J. Thompson, 11.05.09
(defun c:LOS (/ _Layers #List #Filter #SS)
 (setq _Layers (lambda (/ d n l)
                 (while (setq d (tblnext "layer" (null d)))
                   (and (not (wcmatch (setq n (cdr (assoc 2 d))) "*|*"))
                        (setq l (cons n l))
                   ) ;_ and
                 ) ;_ while
                 (vl-sort l '<)
               ) ;_ lambda
 ) ;_ setq
 (cond
   ((if dos_multilist
      (setq #List (dos_multilist "Select all objects on Layers" "Select layers:" (_Layers)))
      (setq #List (AT:ListSelect
                    "Select all objects on Layers"
                    "Select layers:"
                    "30"
                    "15"
                    "true"
                    (_Layers)
                  ) ;_ AT:ListSelect
      ) ;_ setq
    ) ;_ if
    (setq #Filter "")
    (foreach x #List (setq #Filter (strcat #Filter x ",")))
    (and (setq #SS (ssget "_X" (list (AT:TabFilter) (cons 8 #Filter))))
         (sssetfirst nil #SS)
         (print #List)
    ) ;_ and
   )
 ) ;_ cond
 (princ)
) ;_ defun

;;; Draw single orthogonal line segment
;;; Alan J. Thompson, 11.24.09
(defun c:UL (/ *error* #Pnt)
 (setq *error* (lambda (x) (setvar 'orthomode 0)))
 (while (setq #Pnt (getpoint "\nSpecify first point: "))
   (princ "\nSpecify next point: ")
   (setvar 'orthomode 1)
   (vl-cmdf "_.line" "_non" #Pnt PAUSE "")
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; Extended Trim (Trim select objects to imaginary drawn line)
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 11.24.09
(defun c:TRX (/ *error* #Pt1 #Pt2 #Line #Ent)
 (setq *error* (lambda (x) (and #Line (vl-catch-all-apply 'entdel (list #Line)))))
 (and
   (setq #Pt1 (getpoint "\nSpecify first point: "))
   (setq #Pt2 (getpoint #Pt1 "\nSpecify next point: "))
   (setq
     #Line (entmakex (list '(0 . "LINE") (cons 10 (trans #Pt1 1 0)) (cons 11 (trans #Pt2 1 0))))
   ) ;_ setq
   (while
     (setq
       #Ent (AT:Entsel nil
                       "\nSelect object to trim: "
                       '(":L" (0 . "LINE,*POLYLINE,ARC,CIRCLE,ELLIPSE,HATCH,DIMENSION"))
                       nil
            ) ;_ AT:Entsel
     ) ;_ setq
      (vl-cmdf "_.trim" #Line "" #Ent "")
   ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

Oops, forgot to post the extend one...

;;; Extended Extend (Extend select objects to imaginary drawn line)
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 10.21.09
(defun c:EXX (/ *error* #Pt1 #Pt2 #Line #Ent)
 (setq *error* (lambda (x) (and #Line (vl-catch-all-apply 'entdel (list #Line)))))
 (and
   (setq #Pt1 (getpoint "\nSpecify first point: "))
   (setq #Pt2 (getpoint #Pt1 "\nSpecify next point: "))
   (setq
     #Line (entmakex (list '(0 . "LINE") (cons 10 (trans #Pt1 1 0)) (cons 11 (trans #Pt2 1 0))))
   ) ;_ setq
   (while
     (setq
       #Ent (AT:Entsel nil
                       "\nSelect object to extend: "
                       '(":L" (0 . "LINE,*POLYLINE,ARC,DIMENSION"))
                       nil
            ) ;_ AT:Entsel
     ) ;_ setq
      (vl-cmdf "_.extend" #Line "" #Ent "")
   ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; Layout Zoom Window (zoom to same window in all layouts)
;;; Alan J. Thompson, 11.10.09
(defun c:LZW (/ *error* #Ctab #Pnt #Cor #Pnts)
 (setq *error* (lambda (x) (and #Ctab (setvar 'ctab #Ctab))))
 (or *Acad* (setq *Acad* (vlax-get-acad-object)))
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument *Acad*)))
 (cond
   ((zerop (getvar 'tilemode))
    (vla-put-mspace *AcadDoc* :vlax-false)
    (setq #Ctab (getvar 'ctab))
    (cond
      ((and (setq #Pnt (getpoint "\nSpecify first corner: "))
            (setq #Cor (getcorner #Pnt "\nSpecify opposite corner: "))
       ) ;_ and
       (setq #Pnts (mapcar 'vlax-3D-point (list #Pnt #Cor)))
       (foreach x (layoutlist)
         (setvar 'ctab x)
         (vla-put-mspace *AcadDoc* :vlax-false)
         (vla-zoomwindow *Acad* (car #Pnts) (cadr #Pnts))
       ) ;_ foreach
      )
    ) ;_ cond
   )
   (T (alert "Sorry, command not allowed in Model Tab."))
 ) ;_ cond
 (*error* nil)
 (princ)
) ;_ defun