alanjt's Misc. Useful Lisp Subroutines

[alanjt]

;;; Fix number with leading zeros
;;; #Num - Number to fix
;;; #Length - Number of characters for final string
;;; Alan J. Thompson, 10.29.09
(defun AT:NumFix (#Num #Length / #Str)
 (setq #Str (vl-princ-to-string #Num))
 (while (< (strlen #Str) #Length)
   (setq #Str (strcat "0" #Str))
 ) ;_ while
 #Str
) ;_ defun

[alanjt]

;;; Copy entire contents of directory to new location (subfolders included)
;;; #Source - source folder to copy
;;; #Dest - destination directory (will be created if doesn't exist)
;;; Alan J. Thompson, 10.06.09
(defun AT:XCopyDirectory (#Source #Dest / *error* #Scr)
 (setq *error* (lambda (x) (and #Scr (vlax-release-object #Scr))))
 (cond ((findfile #Source)
        (setq #Scr (vlax-get-or-create-object "WScript.Shell"))
        (vlax-invoke-method #Scr "Run" (strcat "XCopy " #Source " /E /H /Q /Y /I " #Dest) 0)
       )
 ) ;_ cond
 (*error* nil)
) ;_ defun

[alanjt]

;;; Parse number string X-Y into list of numbers
;;; #Num - Number string (ie: "2-10")
;;; Requied Subroutines: AT:Str2Lst
;;; Example: (AT:NumberParse "2-5") -> (2 3 4 5)
;;; Alan J. Thompson, 02.18.10
(defun AT:NumberParse (#Num / #Num #List)
 (setq #Num  (AT:Str2Lst #Num "-")
       #List (list (atoi (car #Num)))
 ) ;_ setq
 (while (< (car #List) (atoi (last #Num)))
   (setq #List (cons (1+ (car #List)) #List))
 ) ;_ while
 (reverse #List)
) ;_ defun

 

You'll need this...

;;; Convert string to list, based on separator
;;; #Str - String to convert
;;; #Sep - Separator to break string into items
;;; Ex. - (AT:Str2Lst "1,2,3" ",") -> '("1" "2" "3")
;;; Alan J. Thompson, 11.11.09
(defun AT:Str2Lst (#Str #Sep / #Inc #List #Str)
 (while (setq #Inc (vl-string-search #Sep #Str))
   (setq #List (cons (substr #Str 1 #Inc) #List))
   (setq #Str (substr #Str (+ 2 #Inc)))
 ) ;_ while
 (vl-remove "" (append (reverse #List) (list #Str)))
) ;_ defun

[alanjt]

;;; Set Draworder of specified vla-objects
;;; #Mode - Draworder mode ('MoveToTop 'MoveToBottom 'MoveAbove 'MoveBelow)
;;; #ObjList - List of vla-objects to set draworder of
;;; #Target - Target object (only if using 'MoveAbove or 'MoveBelow, otherwise leave nil)
;;; Alan J. Thompson, 10.16.09
(defun AT:Draworder (#Mode #ObjList #Target / #Dict)
 (and
   (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
   (not (vl-catch-all-error-p
          (setq #Dict (vl-catch-all-apply
                        'vla-AddObject
                        (list (vla-GetExtensionDictionary
                                (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
                                        (eq :vlax-true (vla-get-mspace *AcadDoc*))
                                    ) ;_ or
                                  (vla-get-modelspace *AcadDoc*)
                                  (vla-get-paperspace *AcadDoc*)
                                ) ;_ if
                              ) ;_ vla-GetExtensionDictionary
                              "ACAD_SORTENTS"
                              "AcDbSortentsTable"
                        ) ;_ list
                      ) ;_ vl-catch-all-apply
          ) ;_ setq
        ) ;_ vl-catch-all-error-p
   ) ;_ not
   (if (vl-position #Mode '(MoveAbove MoveBelow))
     (not
       (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list #Dict #Mode #ObjList #Target)))
     ) ;_ not
     (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list #Dict #Mode #ObjList))))
   ) ;_ if
 ) ;_ and
) ;_ defun

[alanjt]

;;; VLA Get Property (catches errors)
;;; #Obj - VLA-Object to retrieve property from
;;; #Prop - Property to retrieve from VLA-Object
;;; Alan J. Thompson, 11.03.09
(defun AT:Get (#Obj #Prop / #Check)
 (if (not (vl-catch-all-error-p
            (setq #Check (vl-catch-all-apply 'vlax-get-property (list #Obj #Prop)))
          ) ;_ vl-catch-all-error-p
     ) ;_ not
   #Check
 ) ;_ if
) ;_ defun

 

 

;;; VLA Put Property (catches errors)
;;; #Obj - VLA-Object to put property
;;; #Prop - Property to put on VLA-Object
;;; #Value - Value to put to VLA-OBJECT
;;; Alan J. Thompson, 11.24.09
(defun AT:Put (#Obj #Prop #Value)
 (not (vl-catch-all-error-p
        (vl-catch-all-apply 'vlax-put-property (list #Obj #Prop #Value))
      ) ;_ vl-catch-all-error-p
 ) ;_ not
) ;_ defun

[alanjt]

;;; Multiply number of characters in a string
;;; #Chr - Character to multiply
;;; #Num - Number desired
;;; Alan J. Thompson, 12.07.09
(defun AT:MultipleCharacter (#Chr #Num / #Str)
 (setq #Str "")
 (while (> #Num (strlen #Str))
   (setq #Str (strcat #Str #Chr))
 ) ;_ while
 #Str
) ;_ defun

[alanjt]

;;; Extract numbers from string
;;; #String - String to extract numbers from
;;; Required Subroutines: AT:Str2Lst
;;; Alan J. Thompson, 11.13.09
(defun AT:ExtractNumbers (#String)
 (mapcar 'read
         (vl-remove "."
                    (AT:Str2Lst
                      (vl-list->string
                        (mapcar
                          '(lambda (x)
                             (if (vl-position x (list 46 48 49 50 51 52 53 54 55 56 57))
                               x
                               32
                             ) ;_ if
                           ) ;_ lambda
                          (vl-string->list #String)
                        ) ;_ mapcar
                      ) ;_ vl-list->string
                      " "
                    ) ;_ AT:Str2Lst
         ) ;_ vl-remove
 ) ;_ mapcar
) ;_ defun

[alanjt]

;;; List of linetypes in drawing (dotted pair name and description list returned)
;;; XRef, ByLayer and ByBlock ignored
;;; Alan J. Thompson, 02.23.10
(defun AT:LinetypeNameDescList (/ #List)
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vlax-for x (vla-get-linetypes *AcadDoc*)
   (or (wcmatch (vla-get-name x) "*|*,ByLayer,ByBlock")
       (setq #List (cons (cons (vla-get-name x) (vla-get-description x)) #List))
   ) ;_ or
 ) ;_ vlax-for
 (vl-sort #List '(lambda (a b) (< (car a) (car b))))
) ;_ defun

[fixo]

Alan,

 

Thanks for your good work

 

Regards,

 

~'J'~

[alanjt]

Alan,

 

Thanks for your good work

 

Regards,

 

~'J'~

 

Thanks and enjoy.

[harrison-matt]

Alan,

 

I was trying to use your AT:LayoutList with your TabInc Command and I am receiving this error: no function definition: VLAX-GET-ACAD-OBJECT?? which is in this line of code in AT:LayoutList:

 

  (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))

 

Which -acad-object should I be GET-ING!?

 

Thanks,

Matt

[Lee Mac]

Be sure to add

 

(vl-load-com)

 

to the code, or to your ACADDOC.lsp to load the Visual LISP functions.

[harrison-matt]

Thanks Lee,

 

Forgot about that one!

 

Matt

[Lee Mac]

No worries Matt Most of us include a call to (vl-load-com) in the ACADDOC.lsp, and so its very hard to spot if you miss it from a routine...

[alanjt]

Alan,

 

I was trying to use your AT:LayoutList with your TabInc Command and I am receiving this error: no function definition: VLAX-GET-ACAD-OBJECT?? which is in this line of code in AT:LayoutList:

 

  (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))

Which -acad-object should I be GET-ING!?

 

Thanks,

Matt

 

No worries Matt Most of us include a call to (vl-load-com) in the ACADDOC.lsp, and so its very hard to spot if you miss it from a routine...

 

 

Yeah, I don't like to add (vl-load-com) to my subroutines, since I will generally add it to the beginning of the primary routine plus, as Lee stated, most of us add (vl-load-com) to our startup file.

[Guest PwrGeo]

Hi Alan,

I need help changing the background mask color of multiple Multileaders.

AutoCAD allows you to Matchprop on Mtext and the background mask color changes no prob, but not with Mleaders.

I found Mtextmask-update.lsp for changing mask color of multiple Mtext entries but it doesn't work on Mleaders.

The closest I found is your Textmasktoggle.lsp, but I don't know how to change it or if it is possible.

Could it be modified for changing mask colors for multileader text?

Thanks in advance for any help you can give.

Geo

[butzers09silverado]

how do you add that sub routine? Do I just add this as a lisp via appload or does this actually need to go inside of each routine?

 

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

[alanjt]

how do you add that sub routine? Do I just add this as a lisp via appload or does this actually need to go inside of each routine?

Either way. Shout if you need some help.

[butzers09silverado]

deleted....

 

i searched this specific thread and found the AT:segment.... nevermind, lol

 

thanks!

[alanjt]

deleted....

 

i searched this specific thread and found the AT:segment.... nevermind, lol

 

thanks!

Good deal. I couldn't remember if I had added it or not. I was about to add it when I read your edit.

Enjoy.