alanjt's Misc. Useful Lisp Routines

[alanjt]

To compliment the subroutine thread:

http://www.cadtutor.net/forum/showthread.php?t=40344

 

Some of these I wrote pretty early on. I wasn't very good (not that I'm much better), but they work (regardless of them being ugly), and I have better things to waste my time on than making old routines more ascetically pleasing.

 

 

;fillet with set radius
;Alan J. Thompson
(mapcar
 '(lambda (f r)
    (eval (list 'defun
        f
        nil
        (list 'setvar "filletrad" r)
        (list 'princ (strcat "\nFillet radius set to: " (rtos r)))
        (list 'command "_.fillet")
        '(princ)
      )
    )
  )
 '(c:FF    c:F1    c:F15    c:F2    c:F3    c:F4    c:F45    c:F5    c:F6    c:F7    c:F8    c:F9)
 '(0        1    1.5    2    3    4    4.5    5    6    7    8    9)
)

[alanjt]

;fillet (windowed) objects
(defun c:fc()(command "fillet" "c")(princ))


;MAKE A LAYER
(defun c:LM ()
(command "-layer" "make" )
(princ))


;ALLOWS YOU TO FREEZE BY ENTERING IN LAYER NAMES (WILD CARDS ALLOWED)
(defun c:LAZ ()
(command "-layer" "freeze" )
(princ))


;ALLOWS YOU TO TURN OFF LAYERS BY ENTERING IN LAYER NAMES (WILD CARDS ALLOWED)
(defun c:LAF ()
(command "-layer" "off" )
(princ))


;LOCK LAYER(S) BY PICK OR BY NAME (WILD CARDS ALLOWED)
(defun c:LK ()
(command "-layer" "lock" )
(princ))

;UNLOCK LAYER(S) BY PICK OR BY NAME (WILD CARDS ALLOWED)
(defun c:LU ()
(command "-layer" "unlock" )
(princ))

;set vports to 1
(defun c:V1()
(command "-vports" "si")
(princ))

;set vports to 2
(defun c:V2()
(command "-vports" "2" "v")
(princ))


;zoom extents
(defun C:ZX ()
 (vla-ZoomExtents
   (vlax-get-acad-object)
 ) ;_ vla-ZoomExtents
 (prompt "\nZoom Extents")
 (princ)
) ;_ defun


;zoom previous
(defun C:ZQ ()
 (vla-ZoomPrevious
   (vlax-get-acad-object)
 ) ;_ vla-ZoomPrevious
 (prompt "\nZoom Previous")
 (princ)
) ;_ defun


;UNLOAD ALL XREFS
(defun c:xu ()
(command "-xref" "UNLOAD" "*")
(princ))


;RELOAD ALL XREFS
(defun c:XE ()
(command "-xref" "RELOAD" "*" )
(princ))


;LENGTHEN (TOTAL)
(defun c:LG()
(princ "\nLengthen Total")
(command "lengthen" "t")
(princ))


;LENGTHEN (DELTA)
(defun c:DE ()
(princ "\nLengthen Delta")
(command "lengthen" "de")
(princ))


;CHANGE MACRO
(defun c:CH ( / ss_objects )
(princ "\nChange")
(setq ss_objects (ssget ":L"))
(if ss_objects
 (vl-cmdf "_.change" ss_objects "" "_p")
 (princ "\nNothing selected, try again.")
);if
(princ)
);defun

[alanjt]

Just as it says, creates quick Dummy layers.

 

;DUMMY LAYERS (CREATES AND/OR SETS AS CURRENT)
(defun AT:DummyLayer (DL_Name DL_Color DL_Plot)
 (cond
   ((tblsearch "layer" DL_Name)
    (vl-cmdf "_.layer" "_t" DL_Name "_s" DL_Name "_p" DL_Plot DL_Name
             "") ;_ vl-cmdf
    (princ
      (strcat "\nLayer: \"" DL_Name "\" is the current layer.")
    ) ;_ princ
   )
   (T
    (vl-cmdf "_.layer" "_m"      DL_Name   "_c"      DL_Color
             DL_Name   "_p"      DL_Plot   DL_Name   ""
            ) ;_ vl-cmdf
    (princ (strcat "\nLayer: \"" DL_Name "\" has been created.")
    ) ;_ princ
   )
 ) ;_ cond
 (princ)
) ;_ defun

;"ALAN" LAYER
(defun c:ALAN (/) (AT:DummyLayer "ALAN" 2 "P") (princ))

[alanjt]

;arc by 2 selected endpoints, then entering or selecting radius
(defun c:AR ( / point_1 point_2 )
(if
 (and
  (setq point_1 (getpoint "\nPick 1st Point: "))
  (setq point_2 (getpoint point_1 "\nPick 2nd Point: "))
 );and
 (command "_.arc" "_non" point_1 "_e" "_non" point_2 "_r")
 (princ "\nMissed, try again.")
);if
(princ)
);defun


;create section outline
(defun c:SEC ( / sec_pnt )
(if (setq sec_pnt (getpoint "\nPick NW corner of section: "))
      (command "_.pline" sec_pnt "@5280<n90de" "@5280<s0de" "@5280<n90dw" "@5280<n0dw" "")
      (princ "\nMissed, try again.")
);if
(princ)
);defun

[alanjt]

;set selected objects to "ByLayer"
(defun c:SBL ( / #ssget )
(if
 (setq #ssget (ssget ":L"))
  (vl-cmdf "_.setbylayer" #ssget "" "_y" "_y")
  (princ "\nMissed, try again.")
);if
(princ)
);defun

[alanjt]

;mtext with 0 width
(defun c:T (/ #GetPoint)
(initdia)
(command "_.mtext")
(if (setq #GetPoint (getpoint "\nSpecify first corner: "))
  (command #GetPoint "_w" 0)
)
(princ)
)


;mtext center justified, 0 width
(defun c:TY (/ #GetPoint)
(initdia)
(command "_.mtext")
(if (setq #GetPoint (getpoint "\nSpecify first corner: "))
  (command #GetPoint "_j" "_mc" "_w" 0)
)
(princ)
)


;clipboard selected objects with basepoint of 0,0,0
(defun c:C0 ( / #ssget )
(if (setq #ssget (ssget ":L"))
 (progn
  (vl-cmdf "_.copybase" "0,0,0" #ssget "")
  (prompt (strcat "\n" (rtos (sslength #ssget) 2 0) " object(s) have been clipboarded at: 0,0,0"))
 );progn
);if
(princ)
);defun

[alanjt]

;break object @ point
;alan thompson, 3.26.09
(defun c:BA (/ *error* #GetvarList #SetvarList #Entsel #Getpoint)
 (defun *error* (msg)
   (mapcar 'setvar #GetvarList #SetvarList)
 ) ;_ defun

 (setq #GetvarList (list "cmdecho" "osmode"))
 (setq #SetvarList (mapcar 'getvar #GetvarList))
 (setvar "cmdecho" 0)
 (setvar "errno" 0)
 (if
   (while
     (and
       (not #Entsel)
       (not (eq (getvar "errno") 52))
     ) ;and
      (setq #Entsel (entsel "\nSelect object to break: "))
   ) ;while
    (progn
      (setq #Getpoint (getpoint "\nSelect point to break @ or <Selection Point>: "))
      (setvar "osmode" 0)
      (if (not #GetPoint)
        (setq #GetPoint (osnap (cadr #Entsel) "_near"))
      ) ;_ if
      (vl-cmdf "_.break" #Entsel "_f" "_non" #Getpoint "_non" #Getpoint) ;_ vl-cmdf
    ) ;_ progn
    (princ "\nMissed, try again.")
 ) ;if
 (mapcar 'setvar #GetvarList #SetvarList)
 (princ)
) ;defun

[alanjt]

;rotate a copy of selected object(s)
(defun c:RC ( / #SSGet #GetPoint )
(prompt "\nSelect objects of which to rotate a copy: ")
(if
 (and
  (setq #SSGet (ssget ":L"))
  (setq #GetPoint (getpoint "\nSpecify base point: "))
 )
   (vl-cmdf "_.rotate" #SSGet "" "_non" #GetPoint "_c")
   (prompt "\nMissed, try again.")
)
(princ)
)

[alanjt]

;;; Calculate Percent Slope
;;; Alan J. Thompson, 04.30.09
(defun c:Slope ( / #Elev1 #Elev2 #Dist #Calc)
 (cond
   ((and (setq #Elev1 (getreal "\nElevation 1: "))
         (setq #Elev2 (getreal "\nElevation 2: "))
         (setq #Dist (getdist "\nDistance: "))
         )
    (setq #Calc (strcat "\nElevation 1:  " (rtos #Elev1 2 2)
                        "\nElevation 2:  " (rtos #Elev2 2 2)
                        "\nDistance:     " (rtos #Dist 2 2)
                        "\n---------------------------"
                        "\nSlope: " (rtos (* 100 (/ (- #Elev1 #Elev2) #Dist)) 2 2) "%"
                        )
          )
    (prompt #Calc)
    (alert #Calc)
    )
   )
 (princ)
 )

;;; Calculate grade of unknown point
;;; Alan J. Thompson, 05.11.09
(defun c:GRADE (/ #Dist #Elev #Grade #NewElev)
 (cond
   ((and (setq #Dist (getdist "\nDistance: "))
         (setq #Elev (getreal "\nElevation of known point: "))
         (setq #Grade (getreal "\nPercent grade (eg: 0.25 for 0.25%): "))
    ) ;_ and
    (setq #NewElev (strcat "\nElevation: "
                           (rtos (+ (* #Dist (/ #Grade 100)) #Elev) 2 3)
                   ) ;_ strcat
    ) ;_ setq
    (princ #NewElev)
    (alert #NewElev)
   )
 ) ;_ cond
 (princ)
) ;_ defun

[alanjt]

;;; Move all Text, Mtext, Multileader, Dimension objects to front
;;; Alan J. Thompson, 06.01.09
(defun c:TTF (/ #SSGet)
 (or (ssget "_I")
     (prompt
       "\nSelect Text, Multileader, Dimension objects to move to front: "
     ) ;_ prompt
 ) ;_ or
 (cond
   ((setq #SSGet (ssget ":L" '((0 . "MTEXT,TEXT,MULTILEADER,DIM*"))))
    (vl-cmdf "_.draworder" #SSGet "" "_f")
    (prompt
      (strcat (itoa (sslength #SSGet))
              " Text, Multileader, Dimension objects moved to front."
      ) ;_ strcat
    ) ;_ prompt
   )
 ) ;_ cond
 (princ)
) ;_ defun

[alanjt]

;;; Quick Hatch: hatch with all previously set hatch settings
;;; Only works if hatching by picked internal point
(defun c:HH (/ #Point)
 (and (princ "\nQuick Hatch")
      (while (setq #Point (getpoint "\nSpecify internal point: "))
        (vl-cmdf "_.-hatch" #Point "")
      ) ;_ while
 ) ;_ and
 (princ)
) ;_ defun

[alanjt]

;;; Quick Attribute Editor (edit selected attribute string)
;;; Subroutines Required: AT:Entsel AT:GetString
;;; Alan J. Thompson, 08.25.09
(defun c:AE (/ #Entsel #String)
 (and (setq #Entsel (AT:Entsel T
                               "\nSelect attribute to edit: "
                               '((0 . "ATTRIB"))
                               nil
                    ) ;_ AT:Entsel
      ) ;_ setq
      (setq #Entsel (vlax-ename->vla-object (car #Entsel)))
      (setq #String (AT:GetString
                      "Edit Attribute"
                      (vla-get-TextString #Entsel)
                    ) ;_ AT:GetString
      ) ;_ setq
      (vla-put-TextString #Entsel #String)
 ) ;_ and
 (princ)
) ;_ defun

[alanjt]

I forgot to mention, some of these will require subroutines. I should have posted them all in the Subroutine thread. The link is the first post of this thread.

[alanjt]

;;; Display and/or change width of selected Polyline or LWPolyline
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 08.27.09
(defun c:W (/ #Object #OldWidth #NewWidth #ExitFlag)
 (cond
   ((setq #Object (AT:Entsel nil
                             "\nSelect Polyline: "
                             '((0 . "POLYLINE,LWPOLYLINE"))
                             nil
                  ) ;_ AT:Entsel
    ) ;_ setq
    (setq #Object    (vlax-ename->vla-object (car #Object))
          #OldWidth  (vla-get-constantwidth #Object)
          #PlineType (substr (vla-get-objectname #Object) 5)
    ) ;_ setq
    ;; pline selected & width extracted, time to prompt & set new width
    (while (and (not #ExitFlag)
                (not (initget 4 "Exit"))
                (setq #NewWidth
                       (getreal
                         (strcat "\nSelected "
                                 #PlineType
                                 " width: "
                                 (vl-princ-to-string #OldWidth)
                                 "\nSpecify new width or [Exit] <Exit>: "
                         ) ;_ strcat
                       ) ;_ getreal
                ) ;_ setq
           ) ;_ and
      (cond
        ;; new width specified
        ((numberp #NewWidth)
         (vla-put-constantwidth #Object #NewWidth)
         (setq #OldWidth #NewWidth)
         (prompt (strcat "\n* - * = * - * -> "
                         #PlineType
                         " width changed to: "
                         (vl-princ-to-string #NewWidth)
                         " <- * - * = * - *"
                 ) ;_ strcat
         ) ;_ prompt
        )
        ;; nil or user typed in "Exit"
        ((or (not #NewWidth)
             (eq #NewWidth "Exit")
         ) ;_ or
         (setq #ExitFlag T)
        )
      ) ;_ cond
    ) ;_ while
   )
 ) ;_ cond
 (princ)
) ;_ defun

[alanjt]

;;; Fillet with entered radius or radius of selected arc (option to delete selected arc)
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 09.03.09
(defun c:FR (/ #Radius #Object #Choice)
 (initget 4 "Select")
 (or (setq
       #Radius (getdist
                 (strcat
                   "\nSpecify fillet radius or select arc [select] <"
                   (rtos (getvar "filletrad") 2 2)
                   ">: "
                 ) ;_ strcat
               ) ;_ getdist
     ) ;_ setq
     (setq #Radius (getvar "filletrad"))
 ) ;_ or
 (cond
   ((eq #Radius "Select")
    (and (setq #Object (AT:Entsel nil
                                  "\nSelect arc to extract radius: "
                                  '("VL" (0 . "ARC"))
                                  nil
                       ) ;_ AT:Entsel
         ) ;_ setq
         (princ
           (strcat "\nFillet Radius: "
                   (vl-princ-to-string
                     (setvar "filletrad" (vla-get-radius #Object))
                   ) ;_ vl-princ-to-string
           ) ;_ strcat
         ) ;_ princ
         (not (initget 0 "Yes No Delete"))
         (if (and (or (setq #Choice
                             (getkword "\nDelete selected arc? [Yes/No] <No>: "
                             ) ;_ getkword
                      ) ;_ setq
                      (setq #Choice "No")
                  ) ;_ or
                  (member #Choice (list "Yes" "Delete"))
             ) ;_ and
           (not (vla-delete #Object))
           T
         ) ;_ if
         (vl-cmdf "_.fillet")
    ) ;_ and
   )
   ((numberp #Radius)
    (setvar "filletrad" #Radius)
    (vl-cmdf "_.fillet")
   )
 ) ;_ cond
 (princ)
) ;_ defun

[alanjt]

;;; Offset selected object to current layer
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 09.08.09
(defun c:OL (/ #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 to current layer: "
                      '("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 "")
      (vla-put-layer
        (vlax-ename->vla-object (entlast))
        (getvar "clayer")
      ) ;_ vla-put-layer
   ) ;_ while
 ) ;_ and
 (princ)
) ;_ defun

[alanjt]

Couple C3D macros:

;line by bearing & distance
(defun c:BL ( / begin_point )
(setq begin_point (getpoint "\nPick starting point: "))
(if (not begin_point)
  (setq begin_point (getvar "lastpoint"))
);if
(vl-cmdf "_.line" "_non" begin_point "'BD")
(princ)
);defun


;delete selected segment labels
(defun c:NL (/ ss)
 (prompt "\nSelect C3D Segment Labels to erase: ")
 (setq ss (ssget '((0 . "AECC_GENERAL_SEGMENT_LABEL"))))
 (if ss
   (progn
     (command "erase" ss "" )
     (princ (strcat "\n " (rtos (sslength ss) 2 0) " C3D Segment Label(s) have been deleted."))
   );progn
   (princ "\nMissed, try again.")
 );if
 (princ)
);defun


;;; set object layer for segment & note label
;;; Alan J. Thompson, 05.18.09
(defun c:LAS (/)
 (cond ((and AT:SetObjectLayer)
        (AT:SetObjectLayer 'GeneralNoteLabelLayer (getvar "clayer"))
        (AT:SetObjectLayer 'GeneralSegmentLabelLayer
                           (getvar "clayer")
        ) ;_ AT:SetObjectLayer
        (prompt
          "\nObject layer for 'GeneralNoteLabel' & 'GeneralSegment'\n are set to the current layer!"
        ) ;_ prompt
       )
 ) ;_ cond
 (princ)
) ;_ defun

[alanjt]

Conversion reference

;just some converstion factors
;alan thompson, 1.29.09
(defun c:conv ( / )
(alert (strcat
       "   **** Useful Conversions ***** "
       "\n1 Acre = 43,560 square feet"
       "\n1 Acre = 10 square chains"
       "\n1 Acre = 4047 square meters"
       "\n1 Acre = is about 208 3/4 feet square"
       "\n"
       "\n1 Centimeter = .3937 inches"
       "\n1 Centimeter = .032808 feet"
       "\n"
       "\n1 Chain = 66 feet"
       "\n1 Chain = 100 links"
       "\n1 Chain = 20.1168 meters"
       "\n"
       "\n1 Foot = 0.3048006 meter"
       "\n"
       "\n1 Inch = .0254 meter"
       "\n"
       "\n1 Link = 7.92 inches"
       "\n1 Link = .66 feet"
       "\n1 Link = .2017 meter"
       "\n"
       "\n1 Meter = 3.280833 feet"
       "\n1 Meter = 39.37 inches"
       "\n1 Meter Square = 10.764 square feet"
       "\n"
       "\n1 Mile = 5,280 feet"
       "\n1 Mile = 80 chains"
       "\n1 Mile = 1.60935 kilometers"
       "\n1 Mile = 320 perches"
       "\n1 Mile = 320 poles"
       "\n1 Mile = 8000 links"
       "\n1 Mile = 1,609.2655 meters"
       "\n1 Mile Square = a regular Section of land"
       "\n1 Mile Square = 27,878,400 square feet"
       "\n1 Mile Square = 640 acres"
       "\n"
       "\n1 Section = 1 mile long, by 1 mile wide"
       "\n1 Section = 640 acres"
       "\n"
       "\n1 Township = 6 miles long, by 6 miles wide"
       "\n1 Township = 36 sections"
       "\n1 Township = 36 square miles"
       "\n"
       "\n1 Yard = 36 inches"
       "\n1 Yard = 3 feet"
       "\n1 Yard Square = 9 square feet"
       );strcat
);princ
(princ)
);defun

[alanjt]

;open Windows Explorer In The Directory Of The Active Drawing File.
(defun C:dirr (/)
 (startapp "explorer" (getvar "dwgprefix"))
 (princ)
)

[alanjt]

;;;justification macros (center, left, right)
;;;created by: alan thompson, 3.21.08
;;;updated by: alan thompson, 3.6.09 (fixed ssget to ignore objects on locked layers)
;;;updated by: alan thompson, 3.16.09 (added Top & Bottom Center)


;;; Justify Text "MIDDLE CENTER"
(defun c:JC (/ ss)
 (princ "\nSelect Text to Middle Center Justify: ")
 (if
   (setq ss (ssget ":L" '((0 . "*TEXT,ATTDEF"))))
    (vl-cmdf "_.justifytext" ss "" "_mc")
    (princ "\nMissed, try again.")
 ) ;_ if
 (princ)
) ;_ defun

;;; Justify Text "MIDDLE LEFT"
(defun c:JL (/ ss)
 (princ "\nSelect Text to Middle Left Justify: ")
 (if
   (setq ss (ssget ":L" '((0 . "*TEXT,ATTDEF"))))
    (vl-cmdf "_.justifytext" ss "" "_ml")
    (princ "\nMissed, try again.")
 ) ;_ if
 (princ)
) ;_ defun

;;; Justify Text "MIDDLE RIGHT"
(defun c:JR (/ ss)
 (princ "\nSelect Text to Middle Right Justify: ")
 (if
   (setq ss (ssget ":L" '((0 . "*TEXT,ATTDEF"))))
    (vl-cmdf "_.justifytext" ss "" "_mr")
    (princ "\nMissed, try again.")
 ) ;_ if
 (princ)
) ;_ defun


;;; Justify Text "BOTTOM CENTER"
(defun c:BC (/ ss)
 (princ "\nSelect Text to Bottom Center Justify: ")
 (if
   (setq ss (ssget ":L" '((0 . "*TEXT,ATTDEF"))))
    (vl-cmdf "_.justifytext" ss "" "_bc")
    (princ "\nMissed, try again.")
 ) ;_ if
 (princ)
) ;_ defun


;;; Justify Text "TOP CENTER"
(defun c:TC (/ ss)
 (princ "\nSelect Text to Top Center Justify: ")
 (if
   (setq ss (ssget ":L" '((0 . "*TEXT,ATTDEF"))))
    (vl-cmdf "_.justifytext" ss "" "_tc")
    (princ "\nMissed, try again.")
 ) ;_ if
 (princ)
) ;_ defun