alanjt's Misc. Useful Lisp Routines

;;; Lock Everything Else
;;; Alan J. Thompson, 11.10.09
(defun c:LEE (/ *error* #SS #List)
 (setq *error* (lambda (x) (and *AcadDoc* (vla-endundomark *AcadDoc*))))
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark *AcadDoc*)
 (cond
   ((setq #SS (ssget))
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (or (vl-position (vla-get-layer x) #List)
          (setq #List (cons (vla-get-layer x) #List))
      ) ;_ or
    ) ;_ vlax-for
    (vl-catch-all-apply 'vla-delete (list #SS))
    (vlax-for x (vla-get-layers *AcadDoc*)
      (if (vl-position (vla-get-name x) #List)
        (vla-put-lock x :vlax-false)
        (vla-put-lock x :vlax-true)
      ) ;_ if
    ) ;_ vlax-for
   )
 ) ;_ cond
 (*error* nil)
 (princ)
) ;_ defun

;;; Convert selected .LSP file to .FAS, uses same name and places in same directory
;;; Alan J. Thompson, 10.30.09
(defun c:Lsp2Fas (/ #File)
 (vl-load-com)
 (and (setq #File (getfiled "Convert .LSP file to .FAS" "" "lsp" 16))
      (c:vlide)
      (vlisp-compile 'st #File)
      (alert (strcat "LSP -> FAS Complete!\n\n" (vl-string-subst ".fas" ".lsp" (strcase #File T))))
 ) ;_ and
 (princ)
) ;_ defun

;;; Break To Nearest End Point
;;; Trim curve from point on selected object to nearest end point
;;; Required Subroutines: AT:Entsel, AT:ClosestEndPoint
;;; Alan J. Thompson, 12.22.09
(defun c:BE (/ #Ent #POC #POE)
 (and
   (setq #Ent (AT:Entsel nil "\nSelect curve to break: " '("L" (0 . "*POLYLINE,LINE,ARC")) nil))
   (setq #POC (vlax-curve-getClosestPointTo (car #Ent) (trans (cadr #Ent) 1 0)))
   (setq #POE (AT:ClosestEndPoint #Ent))
   (vl-cmdf "_.break" (car #Ent) "_f" "_non" (trans #POC 0 1) "_non" (trans #POE 0 1))
 ) ;_ and
 (princ)
) ;_ defun

;;; Break To Nearest End Point and Extend to Closest Curve
;;; Trim curve from point on selected object to nearest end point and extend to closest curve
;;; Required Subroutines: AT:Entsel, AT:ClosestEndPoint
;;; Alan J. Thompson, 12.22.09
(defun c:BEX (/ #Ent #POC #POE)
 (and
   (setq #Ent (AT:Entsel nil "\nSelect curve to break: " '("L" (0 . "*POLYLINE,LINE,ARC")) nil))
   (setq #POC (vlax-curve-getClosestPointTo (car #Ent) (trans (cadr #Ent) 1 0)))
   (setq #POE (AT:ClosestEndPoint #Ent))
   (vl-cmdf "_.break" (car #Ent) "_f" "_non" (trans #POC 0 1) "_non" (trans #POE 0 1))
   (vl-cmdf "_.extend" "" #Ent "")
 ) ;_ and
 (princ)
) ;_ defun

;;; No Extra Spaces
;;; Required Subroutines: AT:SS->List, AT:NoExtraSpaces, AT:TextString
;;; Alan J. Thompson, 12.23.09
(defun c:NES (/ #SS)
 (and (setq #SS (AT:SS->List (ssget "_:L" '((0 . "MTEXT,TEXT"))) nil))
      (foreach x #SS
        (vla-put-textstring (vlax-ename->vla-object x) (AT:NoExtraSpaces (AT:TextString x)))
      ) ;_ foreach
 ) ;_ and
 (princ)
) ;_ defun

;;; Point Northing & Easting Label
;;; Required Subroutine: AT:MText
;;; Alan J. Thompson, 01.19.10
(defun c:IDL (/ #Pnt #Text #Choice #Land)
 (and (setq #Pnt (getpoint "\nSpecify point: "))
      (setq #Text (mapcar '(lambda (x) (rtos x 2 2)) (setq #Pnt (trans #Pnt 1 0))))
      (not (initget 0 "Yes No"))
      (or (setq #Choice (getkword "\nLeader attachment? [Yes/No] <No>: "))
          (setq #Choice "No")
      ) ;_ or
      (cond
        ((eq #Choice "No")
         (AT:MText #Pnt (strcat "N: " (cadr #Text) "\\PE: " (car #Text)) nil nil 4)
        )
        ((eq #Choice "Yes")
         (and (setq #Land (getpoint (setq #Pnt (trans #Pnt 0 1)) "\nSpecify text location: "))
              (vl-cmdf "_.mleader"
                       "_non"
                       #Pnt
                       "_non"
                       #Land
                       (strcat "N: " (cadr #Text) "\\PE: " (car #Text))
              ) ;_ vl-cmdf
         ) ;_ and
        )
      ) ;_ cond
 ) ;_ and
 (princ)
) ;_ defun

;;; Rename Layer of Selected Object
;;; Required Subroutines: AT:Vlasel, AT:Getstring
;;; Alan J. Thompson, 11.30.09
(defun c:RenL (/ *error* #Obj #Layer #New)
 (setq *error* (lambda (x) (and *AcadDoc* (vla-endundomark *AcadDoc*))))
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark *AcadDoc*)
 (and
   (setq #Obj (AT:Vlasel "\nSelect object to change layer name: "))
   (setq #Layer (vla-get-layer #Obj))
   (not (vl-position
          (setq #New (AT:Getstring "Specify new layer name:" #Layer))
          (list #Layer "" nil)
        ) ;_ vl-position
   ) ;_ not
   (cond
     ((tblsearch "layer" #New) (alert (strcat "\"" #New "\" already exists!")))
     ((not (snvalid #New)) (alert (strcat "\"" #New "\" is an invalid name!")))
     ((and (snvalid #New) (not (tblsearch "layer" #New)))
      (if (vl-catch-all-error-p
            (vl-catch-all-apply
              'vla-put-name
              (list (vla-item (vla-get-layers *AcadDoc*) #Layer) #New)
            ) ;_ vl-catch-all-apply
          ) ;_ vl-catch-all-error-p
        (alert (strcat "Layer: " #Layer " could not be renamed to: " #New))
        (alert (strcat "Layer: " #Layer " renamed to: " #New))
      ) ;_ if
     )
   ) ;_ cond
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; Replace multiple instances of selected blocks (can be different) with selected block
;;; Size and Rotation will be taken from original block and original will be deleted
;;; Required subroutines: AT:Entsel
;;; Alan J. Thompson, 02.09.10
(defun c:BRE (/ *error* #Block #SS #Temp)
 (setq *error* (lambda (x) (and *AcadDoc* (vla-endundomark *AcadDoc*))))
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark *AcadDoc*)
 (cond
   ((and (setq #Block (AT:Entsel nil "\nSelect replacement block: " '("LV" (0 . "INSERT")) nil))
         (princ "\nSelect blocks to be replaced: ")
         (setq #SS (ssget "_:L" '((0 . "INSERT"))))
    ) ;_ and
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      ;; copy original block
      (setq #Temp (vla-copy #Block))
      ;; put new values
      (mapcar '(lambda (p)
                 (vl-catch-all-apply 'vlax-put-property (list #Temp p (vlax-get-property x p)))
               ) ;_ lambda
              (list 'Insertionpoint 'Rotation 'XEffectiveScaleFactor 'YEffectiveScaleFactor
                    'ZEffectiveScaleFactor
                   ) ;_ list
      ) ;_ mapcar
      ;; delete old block
      (vl-catch-all-apply 'vla-delete (list x))
    ) ;_ vlax-for
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (*error* nil)
 (princ)
) ;_ defun

;;; Text Background Mask On/Off
;;; Alan J. Thompson, 02.16.10
(defun c:TBM (/ #SS #Choice)
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (cond
   ((and (setq #SS (ssget "_:L" '((0 . "MTEXT,MULTILEADER"))))
         (not (initget 0 "Yes No"))
         (or (setq #Choice (getkword "\nTurn background mask on? [<Yes>/No]: "))
             (setq #Choice "Yes")
         ) ;_ or
         (if (eq #Choice "Yes")
           (setq #Choice :vlax-true)
           (setq #Choice :vlax-false)
         ) ;_ if
    ) ;_ and
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (cond
        ;; Multileaders
        ((eq (vla-get-objectname x) "AcDbMLeader")
         (vl-catch-all-apply 'vla-put-TextBackgroundFill (list x #Choice))
        )
        ;; MText
        ((eq (vla-get-objectname x) "AcDbMText")
         (vl-catch-all-apply 'vla-put-BackgroundFill (list x #Choice))
        )
      ) ;_ cond
    ) ;_ vlax-for
    (vl-catch-all-apply 'vla-delete (list #SS))
   )
 ) ;_ cond
 (princ)
) ;_ defun

;;; Offset & erase selected object
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 10.07.09
(defun c:OE (/ #Dist #Entsel #Point)
 (and (eq -1 (getvar "offsetdist")) (setvar "offsetdist" 1))
 (initget 6)
 (and
   (or (setq #Dist (getdist (strcat "\nSpecify offset distance <"
                                    (rtos (getvar "offsetdist") 2 2)
                                    ">: "
                            ) ;_ strcat
                   ) ;_ getdist
       ) ;_ setq
       (setq #Dist (getvar "offsetdist"))
   ) ;_ or
   (while
     (and (setq
            #Entsel (AT:Entsel
                      nil
                      "\nSelect object to offset and erase: "
                      '("L"
                        (0 . "LINE,*POLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE")
                       )
                      nil
                    ) ;_ AT:Entsel
          ) ;_ setq
          (setq #Point (getpoint "\nSpecify point on side to offset: "))
     ) ;_ and
      (vl-cmdf "_.offset" #Dist #Entsel #Point "")
      (entdel (car #Entsel))
   ) ;_ while
 ) ;_ and
 (princ)
) ;_ defun

;;; Erase Everything Outside of Selection
;;; Alan J. Thompson, 10.08.09
(defun c:OUT (/ #SS #SSList #Ent)
 (and
   (setq #SS (ssget))
   (foreach x (mapcar 'cadr (ssnamex (ssget "_X" (list (cons 410 (getvar "ctab"))))))
     (setq #Ent (entget (tblobjname "layer" (cdr (assoc 8 (entget x))))))
     (and (not (or (ssmemb x #SS)
                   (minusp (cdr (assoc 62 #Ent)))
                   (not (zerop (cdr (assoc 70 #Ent))))
               ) ;_ or
          ) ;_ not
          (vl-catch-all-apply 'entdel (list x))
     ) ;_ and
   ) ;_ foreach
 ) ;_ and
 (princ)
) ;_ defun

;;; ID Replacement
;;; Alan J. Thompson, 10.08.09
(defun c:PID (/ *error* #Osnapz #Point)
 (setq *error* (lambda (x) (and #Osnapz (setvar "osnapz" #Osnapz))))
 (and (setq #Osnapz (getvar "osnapz")) (setvar "osnapz" 0))
 (and (setq #Point (getpoint "\nSpecify point: "))
      (setq #Point (mapcar '(lambda (x) (rtos x 2 2)) (trans #Point 1 0)))
      (prompt (strcat "\nNorthing (Y): "
                      (cadr #Point)
                      "\nEasting (X): "
                      (car #Point)
                      "\nElevation: "
                      (last #Point)
              ) ;_ strcat
      ) ;_ prompt
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

;;; Zoom to selected object
;;; Alan J. Thompson, 10.15.09
(defun c:OZ (/ #Obj #Pnt1 #Pnt2)
 (and (setq #Obj (ssget "_:E:S"))
      (setq #Obj (vlax-ename->vla-object (ssname #Obj 0)))
      (not (vla-getboundingbox #Obj '#Pnt1 '#Pnt2))
      (vla-zoomwindow (vlax-get-acad-object) #Pnt1 #Pnt2)
 ) ;_ and
 (princ)
) ;_ defun

OK, I think I'm up to date....I think.

Enjoy guys.

OK, I think I'm up to date....I think.

Enjoy guys.

Thanks for taking the time; enjoyed pilfering a few...

S

You know, you could have just put them all in a .zip file for easy downloading.

You know, you could have just put them all in a .zip file for easy downloading.

But how would he bump his post count doing that...

You know, you could have just put them all in a .zip file for easy downloading.

Easier to search, I can update periodically and if I post something that requires a subroutine, I can just refer the person to this thread.

If one is too lazy to scroll through the pages, they're probably too lazy to read though a zip file compilation.

But how would he bump his post count doing that...

Post counts are vanity. We should remove them all together. :wink: But hey, I want a big post count too.

Thanks for taking the time; enjoyed pilfering a few...

S

Glad you found something useful.

;;; Move Previous - Alan J. Thompson
(defun c:MP (/ #SS)
 (and (setq #SS (ssget "_P"))
      (vl-cmdf "_.move" #SS "" (trans (cdr (assoc 10 (entget (ssname #SS 0)))) 0 1))
 ) ;_ and
 (princ)
) ;_ defun

;;; Move Last - Alan J. Thompson
(defun c:MML (/ #SS)
 (and (setq #SS (ssget "_L"))
      (vl-cmdf "_.move" #SS "" (trans (cdr (assoc 10 (entget (ssname #SS 0)))) 0 1))
 ) ;_ and
 (princ)
) ;_ defun

;;; Copy Previous - Alan J. Thompson
(defun c:CP (/ #SS)
 (and (setq #SS (ssget "_P"))
      (vl-cmdf "_.copy" #SS "" (trans (cdr (assoc 10 (entget (ssname #SS 0)))) 0 1))
 ) ;_ and
 (princ)
) ;_ defun

;;; Copy Last - Alan J. Thompson
(defun c:CL (/ #SS)
 (and (setq #SS (ssget "_L"))
      (vl-cmdf "_.copy" #SS "" (trans (cdr (assoc 10 (entget (ssname #SS 0)))) 0 1))
 ) ;_ and
 (princ)
) ;_ defun

Post counts are vanity. We should remove them all together. :wink: But hey, I want a big post count too.

 

 

 

 

Glad you found something useful.

Bitte lassen Sie wie es ist ich finde es super.

Danke

Please leave as it is, I think it's great.

Thanks