alanjt's Misc. Useful Lisp Subroutines

;;; Display directional arrow
;;; #Location - arrow placement point
;;; #Angle - arrow directional angle
;;; Alan J. Thompson, 04.28.09
(defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
 (setq #Size   (* (getvar "viewsize") 0.02)
       #Point1 (polar #Location #Angle #Size)
       #Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
       #Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
 ) ;_ setq
 (grvecs
   (list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1)
 ) ;_ grvecs
) ;_ defun

;;; Egg Timer for calculating run time in milliseconds
;;; Alan J. Thompson, 03.22.09
;;; Argument: #StartStop - 1 for begin, 0 for end
(defun AT:EggTimer (#StartStop)
 (cond
   ((eq 1 #StartStop) (setq *EggTimer* (getvar "millisecs")))
   ((eq 0 #StartStop)
    (if *EggTimer*
      (progn
        (alert
          (strcat "Process Time: "
                  (rtos (- (getvar "millisecs") *EggTimer*))
                  " Milliseconds"
          ) ;_ strcat
        ) ;_ alert
        (setq *EggTimer* nil)
      ) ;_ progn
    ) ;_ if
   )
 ) ;_ cond
) ;_ defun

;;; Draw a square with an "X" in the middle (grdraw)
;;; Alan J. Thompson, 04.07.09
(defun AT:Square (#Point / #Dist)
 (setq #Dist (* (getvar "VIEWSIZE") 0.1))
 ;; RIGHT
 (grdraw (trans (polar #Point (* 0.25 pi) #Dist) 0 1)
         (trans (polar #Point (* 1.75 pi) #Dist) 0 1)
         1
 ) ;_ grdraw
 ;; BOTTOM
 (grdraw (trans (polar #Point (* 1.75 pi) #Dist) 0 1)
         (trans (polar #Point (* 1.25 pi) #Dist) 0 1)
         2
 ) ;_ grdraw
 ;; LEFT
 (grdraw (trans (polar #Point (* 1.25 pi) #Dist) 0 1)
         (trans (polar #Point (* 0.75 pi) #Dist) 0 1)
         3
 ) ;_ grdraw
 ;; TOP
 (grdraw (trans (polar #Point (* 0.75 pi) #Dist) 0 1)
         (trans (polar #Point (* 0.25 pi) #Dist) 0 1)
         4
 ) ;_ grdraw
 ;; X IN MIDDLE (TR->BL)
 (grdraw (trans (polar #Point (* 0.25 pi) #Dist) 0 1)
         (trans (polar #Point (* 1.25 pi) #Dist) 0 1)
         7
 ) ;_ grdraw
 ;; X IN MIDDLE (TL->BR)
 (grdraw (trans (polar #Point (* 0.75 pi) #Dist) 0 1)
         (trans (polar #Point (* 1.75 pi) #Dist) 0 1)
         7
 ) ;_ grdraw
) ;_ defun

;;; Convert color number to string and give
;;; color name if number is between 1 and 7
;;; #ColorNumber - color number to process
;;; Alan J. Thompson, 06.16.09
(defun AT:ColorFix (#ColorNumber)
 (if (numberp #ColorNumber)
   (cond ((eq 1 #ColorNumber) "Red")
         ((eq 2 #ColorNumber) "Yellow")
         ((eq 3 #ColorNumber) "Green")
         ((eq 4 #ColorNumber) "Cyan")
         ((eq 5 #ColorNumber) "Blue")
         ((eq 6 #ColorNumber) "Magenta")
         ((eq 7 #ColorNumber) "White")
         (T (itoa #ColorNumber))
   ) ;_ cond
 ) ;_ if
) ;_ defun

;;; VLA entsel replacement (returns entsel or ENAME as VLA-OBJECT)
;;; #EntityOrMessage - nil: entsel-style selection
;;;                    "string": will display selection message with entsel-style selection
;;;                    Selection: convert to VLA-OBJECT
;;; Alan J. Thompson, 08.11.09
(defun AT:VlaSel (#EntityOrMessage / #EntityOrMessage #VlaObject)
 (or #EntityOrMessage
     (setq #EntityOrMessage "\nSelect object: ")
 ) ;_ or
 (cond
   ((vl-consp #EntityOrMessage)
    (setq #VlaObject (vlax-ename->vla-object (car #EntityOrMessage)))
   )
   ((eq (type #EntityOrMessage) 'STR)
    (setvar "errno" 0)
    (if (while (and (not #VlaObject)
                    (/= 52 (getvar "errno"))
               ) ;_ and
          (setq #VlaObject (entsel #EntityOrMessage))
        ) ;_ while
      (setq #VlaObject (vlax-ename->vla-object (car #VlaObject)))
    ) ;_ if
   )
   ((eq (type #EntityOrMessage) 'ENAME)
    (setq #VlaObject (vlax-ename->vla-object #EntityOrMessage))
   )
 ) ;_ cond
) ;_ defun

;;; Entsel or NEntsel with options
;;; #Nested - Entsel or Nentsel (T for Nentsel, nil for Entsel)
;;; #Message - Selection message (if nil, "\nSelect object: " is used)
;;; #FilterList - DXF ssget style filtering (nil if not required)
;;;               "V" as first item in list to convert object to VLA-OBJECT (must be in list if no DXF filtering)
;;;               "L" as first item in list to ignore locked layers (must be in list if no DXF filtering)
;;; #Keywords - Keywords to match instead of object selection (nil if not required)
;;; Example: (AT:Entsel nil "\nSelect MText not on 0 layer [settings]: " '("LV" (0 . "MTEXT")(8 . "~0")) "Settings")
;;; Example: (AT:Entsel T "\nSelect object [settings]: " '("LV") "Settings")
;;; Alan J. Thompson, 04.16.09
;;; Updated: Alan J. Thompson, 06.04.09 (changed filter coding to work as ssget style dxf filtering)
;;; Updated: Alan J. Thompson, 09.07.09 (added option to ignore locked layers and convert object to VLA-OBJECT
;;; Updated: Alan J. Thompson, 09.18.09 (fixed 'missed pick' alert)
(defun AT:Entsel (#Nested #Message #FilterList #Keywords / #Count
                 #Message #Choice #Ent #VLA&Locked #FilterList
                )
 (vl-load-com)
 (setvar "errno" 0)
 (setq #Count 0)
 ;; fix message
 (or #Message (setq #Message "\nSelect object: "))
 ;; set entsel/nentsel
 (if #Nested
   (setq #Choice nentsel)
   (setq #Choice entsel)
 ) ;_ if
 ;; check if option to convert to vla-object or ignore locked layers in #FilterList variable
 (and (vl-consp #FilterList)
      (eq (type (car #FilterList)) 'STR)
      (setq #VLA&Locked (car #FilterList)
            #FilterList (cdr #FilterList)
      ) ;_ setq
 ) ;_ and
 ;; select object
 (while (and (not #Ent) (/= (getvar "errno") 52))
   ;; if keywords
   (and #Keywords (initget #Keywords))
   (cond
     ((setq #Ent (#Choice #Message))
      ;; if ignore locked layers
      (and #VLA&Locked
           (vl-consp #Ent)
           (wcmatch (strcase #VLA&Locked) "*L*")
           (not
             (zerop
               (cdr (assoc 70
                           (entget (tblobjname
                                     "layer"
                                     (cdr (assoc 8 (entget (car #Ent))))
                                   ) ;_ tblobjname
                           ) ;_ entget
                    ) ;_ assoc
               ) ;_ cdr
             ) ;_ zerop
           ) ;_ not
           (setq #Ent nil
                 #Flag T
           ) ;_ setq
      ) ;_ and
      ;; #FilterList check
      (if (and #FilterList (vl-consp #Ent))
        ;; process filtering from #FilterList
        (or
          (not
            (member
              nil
              (mapcar '(lambda (x)
                         (wcmatch
                           (strcase
                             (vl-princ-to-string
                               (cdr (assoc (car x) (entget (car #Ent))))
                             ) ;_ vl-princ-to-string
                           ) ;_ strcase
                           (strcase (vl-princ-to-string (cdr x)))
                         ) ;_ wcmatch
                       ) ;_ lambda
                      #FilterList
              ) ;_ mapcar
            ) ;_ member
          ) ;_ not
          (setq #Ent nil
                #Flag T
          ) ;_ setq
        ) ;_ or
      ) ;_ if
     )
   ) ;_ cond
   (and (or (= (getvar "errno") 7) #Flag)
        (/= (getvar "errno") 52)
        (not #Ent)
        (setq #Count (1+ #Count))
        (prompt (strcat "\nNope, keep trying!  "
                        (itoa #Count)
                        " missed pick(s)."
                ) ;_ strcat
        ) ;_ prompt
   ) ;_ and
 ) ;_ while
 (if (and (vl-consp #Ent)
          #VLA&Locked
          (wcmatch (strcase #VLA&Locked) "*V*")
     ) ;_ and
   (vlax-ename->vla-object (car #Ent))
   #Ent
 ) ;_ if
) ;_ defun

;;; Convert selection set to list of ename or vla objects
;;; #Selection - SSGET selection set
;;; #VLAList - T for vla objects, nil for ename
;;; Alan J. Thompson, 04.20.09
(defun AT:SS->List (#Selection #VlaList / #List)
 (and #Selection
      (setq #List (vl-remove-if
                    'listp
                    (mapcar 'cadr (ssnamex #Selection))
                  ) ;_ vl-remove-if
      ) ;_ setq
      #VlaList
      (setq #List (mapcar 'vlax-ename->vla-object #List))
 ) ;_ and
 #List
) ;_ defun

;;; Convert list of vla or ename objects to 1 selection set
;;; #SelectionList - list of vla or ename selections
;;; Alan J. Thompson, 05.07.09
(defun AT:List->SS (#SelectionList / #SSAdd)
 (setq #SSAdd (ssadd))
 (mapcar '(lambda (x)
            (if (eq (type x) 'VLA-OBJECT)
              (ssadd (vlax-vla-object->ename x) #SSAdd)
              (ssadd x #SSAdd)
            ) ;_ if
          ) ;_ lambda
         #SelectionList
 ) ;_ mapcar
 #SSAdd
) ;_ defun

;;; Tab filter for ssget selection filtering
;;; Alan J. Thompson, 06.05.09
(defun AT:TabFilter (/)
 (if (eq 2 (getvar "cvport"))
   (cons 410 "Model")
   (cons 410 (getvar "ctab"))
 ) ;_ if
) ;_ defun

;;; Remove all spaces from string
;;; Alan J. Thompson, 03.20.09
(defun AT:NoSpaces (#String / #String)
 (while (vl-string-search " " #String)
   (setq #String (vl-string-subst "" " " #String))
 ) ;_ while
) ;_ defun


;;; Remove all extra spaces from string
;;; Alan J. Thompson, 03.20.09
(defun AT:NoExtraSpaces (#String / #String)
 (vl-string-trim
   " "
   (while (vl-string-search "  " #String)
     (setq #String (vl-string-subst "" "  " #String))
   ) ;_ while
 ) ;_ vl-string-trim
) ;_ defun


;;; Remove/Add Carriage Returns From String
;;; #String - The string.
;;; #Alternate: Replacement for or to be replaced with carriage return
;;; Alan J. Thompson, 03.20.09
(defun AT:CarriageToggle (#String #Alternate / #Find #Replace #String)
 (if (vl-string-search "\\P" #String)
   (setq #Find    "\\P"
         #Replace #Alternate
   ) ;_ setq
   (setq #Find    #Alternate
         #Replace "\\P"
   ) ;_ setq
 ) ;_ if
 (while (or (vl-string-search #Find #String)
            (vl-string-search (strcat #Replace #Replace) #String)
        ) ;_ and
   (setq #String (vl-string-subst
                   #Replace
                   (strcat #Replace #Replace)
                   (vl-string-subst #Replace #Find #String)
                 ) ;_ vl-string-subst
   ) ;_ setq
 ) ;_ while
) ;_ defun

;;; List of Multileader Style VLA-Objects in drawing
;;; Alan J. Thompson, 06.15.09
(defun AT:MLeaderStyleObjList (/)
 (vl-remove-if 'null
               (mapcar '(lambda (x)
                          (if (eq 350 (car x))
                            (vlax-ename->vla-object (cdr x))
                          ) ;_ if
                        ) ;_ lambda
                       (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
               ) ;_ mapcar
 ) ;_ vl-remove-if
) ;_ defun




;;; List of dimension styles in drawing (with or w/o child styles)
;;; #ChildStyles - T for child styles, nil to ignore
;;; Alan J. Thompson, 06.18.09
(defun AT:DimStyleObjList (#ChildStyles / #List)
 (vlax-for x (vla-get-dimstyles
               (vla-get-activedocument
                 (vlax-get-acad-object)
               ) ;_ vla-get-activedocument
             ) ;_ vla-get-dimstyles
   (setq #List (cons x #List))
 ) ;_ vlax-for
 (if #ChildStyles
   #List
   (vl-remove-if '(lambda (x) (wcmatch (vla-get-name x) "*$*"))
                 #List
   ) ;_ vl-remove-if
 ) ;_ if
) ;_ defun




;;; Convert existing dimstyle to VLA-Object
;;; #DimStyleName - name of dimension style
;;; Alan J. Thompson, 06.18.09
(defun AT:DimStyleObj (#DimStyleName / #Obj)
 (and (tblsearch "dimstyle" #DimStyleName)
      (setq #Obj (vla-item (vla-get-dimstyles
                             (vla-get-activedocument
                               (vlax-get-acad-object)
                             ) ;_ vla-get-activedocument
                           ) ;_ vla-get-dimstyles
                           #DimStyleName
                 ) ;_ vla-item
      ) ;_ setq
 ) ;_ and
 #Obj
) ;_ defun

;;; Retreive current UCS angle
;;; Alan J. Thompson, 03.09.09
 (defun AT:UCSAngle (/ xdir)
   (setq xdir (getvar "ucsxdir"))
   (atan (cadr xdir) (car xdir))
 ) ;_ defun

LoL

:twisted::twisted:

;;; Release object (VLA)
;;; Alan J. Thompson, 04.23.09
(defun AT:Release (#Object)
 (and (eq (type #Object) 'VLA-OBJECT)
      (vl-catch-all-apply 'vlax-release-object (list #Object))
 ) ;_ and
) ;_ defun


;;; Send string to commandline
;;; #String - String to send
;;; Alan J. Thompson, 04.28.09
(defun AT:Send (#String)
 (if (eq (type #String) 'STR)
   (vla-sendcommand
     (vla-get-activedocument
       (vlax-get-acad-object)
     ) ;_ vla-get-activedocument
     #String
   ) ;_ vla-sendcommand
 ) ;_ if
) ;_ defun


;;; Regenerate active view
;;; Alan J. Thompson, 04.28.09
(defun AT:Regen (/)
 (vla-Regen (vla-get-ActiveDocument (vlax-get-Acad-Object))
            acActiveViewport
 ) ;_ vla-Regen
) ;_ defun


;;; Save active drawing
;;; Alan J. Thompson, 05.26.09
(defun AT:Save (/)
 (vla-save
   (vla-get-activedocument
     (vlax-get-acad-object)
   ) ;_ vla-get-activedocument
 ) ;_ vla-save
) ;_ defun


;;; Zoom Window a specified area
;;; #Point1 - 1st corner of window
;;; #Point2 - 2nd corner of window
;;; Alan J. Thompson, 06.04.09
(defun AT:ZoomWindow (#Point1 #Point2)
 (and (vl-consp #Point1)
      (vl-consp #Point2)
      (vla-zoomwindow
        (vlax-get-acad-object)
        (vlax-3d-point #Point1)
        (vlax-3d-point #Point2)
      ) ;_ vla-zoomwindow
 ) ;_ and
) ;_ defun



;;; Zoom Extents
;;; Alan J. Thompson, 06.04.09
(defun AT:ZoomExtents (/)
 (vla-zoomextents (vlax-get-acad-object))
) ;_ defun



;;; Zoom Previous
;;; Alan J. Thompson, 06.04.09
(defun AT:ZoomPrevious (/)
 (vla-zoomprevious (vlax-get-acad-object))
) ;_ defun



;;; Switch to model-paperspace (mspace replacement)
;;; Alan J. Thompson, 06.04.09
(defun AT:MSpace (/)
 (and (zerop (getvar "tilemode"))
      (vla-put-mspace (vla-get-activedocument (vlax-get-acad-object))
                      :vlax-true
      ) ;_ vla-put-mspace
 ) ;_ and
) ;_ defun



;;; Switch to paperspace (pspace replacement)
;;; Alan J. Thompson, 06.04.09
(defun AT:PSpace (/)
 (and (zerop (getvar "tilemode"))
      (vla-put-mspace (vla-get-activedocument (vlax-get-acad-object))
                      :vlax-false
      ) ;_ vla-put-mspace
 ) ;_ and
) ;_ defun



;;; Dump VLA info of specified object
;;; #Object - VLA-Object
;;; Alan J. Thompson, 09.07.09
(defun AT:Dump (#Object)
 (if #Object
   (vl-catch-all-apply 'vlax-dump-object (list #Object))
   (vl-catch-all-apply
     '(lambda ()
        (vlax-dump-object
          (vlax-ename->vla-object
            (car (entsel "\nSelect object to dump: "))
          ) ;_ vlax-ename->vla-object
        ) ;_ vlax-dump-object
      ) ;_ lambda
   ) ;_ vl-catch-all-apply
 ) ;_ if
 (textscr)
) ;_ defun

;;; Xref bound name fix (replace "$0$" with desired text)
;;; #Replace - text string to replace "$0$" with
;;; Alan J. Thompson, 09.16.09
(defun AT:XrefBindNameFix (#Replace)
 (and
   (snvalid #Replace)
   (vlax-for x (vla-get-layers
                 (vla-get-activedocument
                   (vlax-get-acad-object)
                 ) ;_ vla-get-activedocument
               ) ;_ vla-get-layers
     (and (vl-string-search "$0$" (vla-get-name x))
          (vl-catch-all-apply
            'vla-put-name
            (list x (vl-string-subst #Replace "$0$" (vla-get-name x)))
          ) ;_ vl-catch-all-apply
     ) ;_ and
   ) ;_ vlax-for
 ) ;_ and
) ;_ defun

;;; Purge Multileader Styles (since vla-purgeall ignores them)
;;; Alan J. Thompson, 08.24.09
(defun AT:MleaderStylePurge (/)
 (vl-remove-if
   'null
   (mapcar
     '(lambda (x)
        (and
          (eq 350 (car x))
          (not (eq 330 (car (nth 5 (entget (cdr x))))))
          (not (eq (getvar "cmleaderstyle")
                   (vla-get-name (vlax-ename->vla-object (cdr x)))
               ) ;_ eq
          ) ;_ not
          (entdel (cdr x))
        ) ;_ and
      ) ;_ lambda
     (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
   ) ;_ mapcar
 ) ;_ vl-remove-if
) ;_ defun

;;; Test if item is specifed type (T=Yes, nil=No)
;;; #Item - Item to compare
;;; #Type - Type to compare with
;;; Alan J. Thompson, 08.28.09
(defun AT:IsType (#Item #Type)
 (eq (type #Item)
     #Type
 ) ;_ eq
) ;_ defun

;;; Check if Current Coordinate System is "World"
;;; Return: T = Yes, nil = No
;;; Alan J. Thompson, 08.28.09
(defun WCS? (/)
 (not (zerop (getvar "worlducs")))
) ;_ defun

;;; List of TextStyle Objects
;;; Alan J. Thompson, 09.02.09
(defun AT:TextStyleObjList (/ #List)
 (vlax-for x (vla-get-textstyles
               (vla-get-activedocument (vlax-get-acad-object))
             ) ;_ vla-get-textstyles
   (setq #List (cons x #List))
 ) ;_ vlax-for
 #List
) ;_ defun



;;; List of Xref Objects
;;; Alan J. Thompson, 09.02.09
(defun AT:XrefObjList (/ #List)
 (vlax-for x (vla-get-blocks
               (vla-get-activedocument (vlax-get-acad-object))
             ) ;_ vla-get-blocks
   (and (eq (vla-get-isxref x) :vlax-true)
        (setq #List (cons x #List))
   ) ;_ and
 ) ;_ vlax-for
 #List
) ;_ defun

;;; Add MText to drawing
;;; #InsertionPoint - MText insertion point
;;; #String - String to place in created MText object
;;; #Width - Width of MText object (if nil, will be 0 width)
;;; #Layer - Layer to place Mtext object on (nil for current)
;;; #Justification - Justification # for Mtext object
;;;             1 or nil= TopLeft
;;;             2= TopCenter
;;;             3= TopRight
;;;             4= MiddleLeft
;;;             5= MiddleCenter
;;;             6= MiddleRight
;;;             7= BottomLeft
;;;             8= BottomCenter
;;;             9= BottomRight
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
                #Space #Insertion #Object
               )
 (or #Width (setq #Width 0))
 (or *AcadDoc*
     (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
 ) ;_ or
 (setq #Space     (if (or (eq acmodelspace
                              (vla-get-activespace *AcadDoc*)
                          ) ;_ eq
                          (eq :vlax-true (vla-get-mspace *AcadDoc*))
                      ) ;_ or
                    (vla-get-modelspace *AcadDoc*)
                    (vla-get-paperspace *AcadDoc*)
                  ) ;_ if
       #Insertion (cond
                    ((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
                    ((eq (type #InsertionPoint) 'variant) #InsertionPoint)
                    (T nil)
                  ) ;_ cond
 ) ;_ setq
 ;; create MText object
 (setq #Object (vla-addmtext #Space #Insertion #Width #String))
 ;; change layer, if applicable
 (and #Layer
      (tblsearch "layer" #Layer)
      (vla-put-layer #Object #Layer)
 ) ;_ and
 ;; change justification & match insertion point with new justification
 (cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
        (vla-put-attachmentpoint #Object #Justification)
        (vla-move #Object
                  (vla-get-InsertionPoint #Object)
                  #Insertion
        ) ;_ vla-move
       )
 ) ;_ cond
 #Object
) ;_ defun