alanjt's Misc. Useful Lisp Routines

[alanjt]

Bitte lassen Sie wie es ist ich finde es super.

Danke

 

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

Thanks

 

It will only change if a Mod. changes it or I get pissed one day and delete everything.

 

Thanks. Hope you found something useful.

[Lee Mac]

I find this really useful, am I'm not even a draftsman...

 

(defun c:cr (/ OldCopy ss)
 (and (setq OldCopy (getvar 'COPYMODE))
      (setvar "COPYMODE" 1))

 (if (setq ss (ssget "_:L"))
   (command "_.copy" ss "" '(0 0 0) '(0 0 0)
            "_.rotate" ss "" pause pause))

 (and OldCopy (setvar 'COPYMODE OldCopy))
 (princ))

[alanjt]

I find this really useful, am I'm not even a draftsman...

 

(defun c:cr (/ OldCopy ss)
 (and (setq OldCopy (getvar 'COPYMODE))
      (setvar "COPYMODE" 1))

 (if (setq ss (ssget "_:L"))
   (command "_.copy" ss "" '(0 0 0) '(0 0 0)
            "_.rotate" ss "" pause pause))

 (and OldCopy (setvar 'COPYMODE OldCopy))
 (princ))

 

 

http://www.cadtutor.net/forum/showpost.php?p=271421&postcount=8

[alanjt]

;;; Tab Incriment
;;; Rename layout tabs with number, based on location
;;; Prefix and Suffix optional
;;; Alan J. Thompson, 02.25.09 (complete rewrite from my original)
(defun c:TabInc (/ #Prefix #Suffix)
 (and (setq #Prefix (getstring T "\nPrefix: "))
      (setq #Suffix (getstring T "\nSuffix: "))
      (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
      (vlax-for x (vla-get-layouts *AcadDoc*)
        (vl-catch-all-apply
          'vla-put-name
          (list x (strcat #Prefix (itoa (vla-get-taborder x)) #Suffix))
        ) ;_ vl-catch-all-apply
      ) ;_ vlax-for
 ) ;_ and
 (princ)
) ;_ defun

[gilsoto13]

Have you seen these subfunctions?... It's nothing really amazing.. just more stuff to add to this great thread...

 

http://www18.ocn.ne.jp/~haru_h/sub10.htm

[alanjt]

;;; Rename Selected Block
;;; Required Subroutines: AT:Entsel, AT:Getstring
;;; Alan J. Thompson, 03.10.10
(defun c:RenB (/ *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:Entsel nil "\nSelect block to rename: " '("V" (0 . "INSERT")) nil))
   (setq #Block (vla-get-effectivename #Obj))
   (not (vl-position
          (setq #New (AT:Getstring "Specify new block name:" #Block))
          (list #Block "" nil)
        ) ;_ vl-position
   ) ;_ not
   (cond
     ((tblsearch "block" #New) (alert (strcat "\"" #New "\" already exists!")))
     ((not (snvalid #New)) (alert (strcat "\"" #New "\" is an invalid name!")))
     ((and (snvalid #New) (not (tblsearch "block" #New)))
      (if (vl-catch-all-error-p
            (vl-catch-all-apply
              'vla-put-name
              (list (vla-item (vla-get-blocks *AcadDoc*) #Block) #New)
            ) ;_ vl-catch-all-apply
          ) ;_ vl-catch-all-error-p
        (alert (strcat "Block: " #Block " could not be renamed to: " #New))
        (alert (strcat "Block: " #Block " renamed to: " #New))
      ) ;_ if
     )
   ) ;_ cond
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

[alanjt]

;;; Measure objects along line/arc
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 03.10.10
(defun c:MAC (/ *error* #SS #Pnt #Obj #Seg #Dist #Len)
 (setq *error* (lambda (x)
                 (and #SS (vl-catch-all-apply 'vla-delete (list #SS)))
                 (and *AcadDoc* (vla-endundomark *AcadDoc*))
               ) ;_ lambda
 ) ;_ setq
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark *AcadDoc*)
 (and
   (princ "\nSelect object(s) to measure 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 #Seg (getdist #Pnt "\nSpecify length of segment: "))
   (setq #Pnt (vlax-3d-point (trans #Pnt 1 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
   (setq #Dist 0.)
   (while (<= #Dist (- #Len #Seg))
     (setq #Dist (+ #Dist #Seg))
     (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
       (vla-move (vla-copy x) #Pnt (vlax-3d-point (vlax-curve-getpointatdist #Obj #Dist)))
     ) ;_ vlax-for
   ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

[alanjt]

;;; Divide objects along line/arc
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson, 11.10.09
(defun c:DAC (/ *error* #SS #Pnt #Obj #Num #Dist #Len)
 (setq *error* (lambda (x)
                 (and *AcadDoc* (vla-endundomark *AcadDoc*))
                 (and #SS (vl-catch-all-apply 'vla-delete (list #SS)))
               ) ;_ lambda
 ) ;_ setq
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark *AcadDoc*)
 (and
   (princ "\nSelect object(s) to divide along curve: ")
   (setq #SS (ssget "_:L"))
   (setq #Pnt (getpoint "\nBase point for objects: "))
   (setq #Pnt (vlax-3d-point (trans #Pnt 1 0)))
   (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)))
     (setq #Dist (+ #Dist (/ #Len #Num)))
     (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
       (vla-move (vla-copy x) #Pnt (vlax-3d-point (vlax-curve-getpointatdist #Obj #Dist)))
     ) ;_ vlax-for
   ) ;_ while
 ) ;_ and
 (*error* nil)
 (princ)
) ;_ defun

[alanjt]

;;; Remove LWPolyline Segment
;;; Required Subroutines: AT:Entsel
;;; Alan J. Thompson
(defun c:Rem (/ e)
 (while (setq e (AT:Entsel nil "\nSelect LWPolyline: " '("L" (0 . "*POLYLINE")) nil))
   (vl-cmdf "_.trim" e "" e "")
 ) ;_ while
 (princ)
) ;_ defun

[alanjt]

;;; Total Area of Selected Polylines
;;; Alan J. Thompson, 03.15.10
(defun c:TA (/ *error* #Dimzin #SS #Area #Len)
 (setq *error* (lambda (x) (and #Dimzin (setvar 'dimzin #Dimzin))))
 (cond
   ((setq #SS (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
    (setq #Dimzin (getvar 'dimzin))
    (setvar 'dimzin 0)
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (setq #Area 0.
          #Len 0.
    ) ;_ setq
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (setq #Area (+ #Area (vla-get-area x))
            #Len  (+ #Len (vla-get-length x))
      ) ;_ setq
    ) ;_ vlax-for
    (vla-delete #SS)
    (textscr)
    (princ (strcat "\nTotal area:"
                   "\n-----------------\n"
                   (rtos #Area 2 2)
                   " SF\n"
                   (rtos (/ #Area 9.) 2 2)
                   " SY\n"
                   (rtos (/ #Area 43560.) 2 2)
                   " AC.±\n"
                   (rtos #Len 2 2)
                   " LF"
           ) ;_ strcat
    ) ;_ princ
   )
 ) ;_ cond
 (*error* nil)
 (princ)
) ;_ defun

[alanjt]

;;; Total Area of Selected Hatch Object(s)
;;; Alan J. Thompson, 03.15.10
(defun c:HA (/ *error* #Dimzin #SS #Area)
 (setq *error* (lambda (x) (and #Dimzin (setvar 'dimzin #Dimzin))))
 (cond
   ((setq #SS (ssget '((0 . "HATCH"))))
    (setq #Dimzin (getvar 'dimzin))
    (setvar 'dimzin 0)
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (setq #Area 0.)
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (setq #Area (+ #Area (vla-get-area x)))
    ) ;_ vlax-for
    (vla-delete #SS)
    (textscr)
    (princ (strcat "\nTotal area:"
                   "\n-----------------\n"
                   (rtos #Area 2 2)
                   " SF\n"
                   (rtos (/ #Area 9.) 2 2)
                   " SY\n"
                   (rtos (/ #Area 43560.) 2 2)
                   " AC.±"
           ) ;_ strcat
    ) ;_ princ
   )
 ) ;_ cond
 (*error* nil)
 (princ)
) ;_ defun

[The Buzzard]

;;; Total Area of Selected Hatch Object(s)
;;; Alan J. Thompson, 03.15.10
(defun c:HA (/ *error* #Dimzin #SS #Area)
 (setq *error* (lambda (x) (and #Dimzin (setvar 'dimzin #Dimzin))))
 (cond
   ((setq #SS (ssget '((0 . "HATCH"))))
    (setq #Dimzin (getvar 'dimzin))
    (setvar 'dimzin 0)
    (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
    (setq #Area 0.)
    (vlax-for x (setq #SS (vla-get-activeselectionset *AcadDoc*))
      (setq #Area (+ #Area (vla-get-area x)))
    ) ;_ vlax-for
    (vla-delete #SS)
    (textscr)
    (princ (strcat "\nTotal area:"
                   "\n-----------------\n"
                   (rtos #Area 2 2)
                   " SF\n"
                   (rtos (/ #Area 9.) 2 2)
                   " SY\n"
                   (rtos (/ #Area 43560.) 2 2)
                   " AC.±"
           ) ;_ strcat
    ) ;_ princ
   )
 ) ;_ cond
 (*error* nil)
 (princ)
) ;_ defun

 

Alan,

 

I just ran this routine on several hatched objects. I do not get an error, But I also do not get any area either. What could I be doing wrong?

 

This is what I get at the command prompt.

 

Command:
HA
Select objects: 1 found
Select objects: 1 found, 2 total
Select objects: 1 found, 3 total
Select objects:
Command:

 

 

Buzzard

[Lee Mac]

The code's error handler does not print error messages, so you wouldn't know if you were receiving an error.

 

Just for diagnostics, try this and see what you get:

 

[The Buzzard]

I get this message now.

 

Select objects: Specify opposite corner: 6 found
3 were filtered out.
Select objects:
ActiveX Server returned the error: unknown name: Area
Command:

[Lee Mac]

The easiest solution would probably be to use a vl-catch-all-apply in there - but this may cause the function to be rendered inaccurate as users would be expecting to receiving areas of more objects than is reported.

 

I'll let Alan deal with the code before I modify it anymore

[alanjt]

Alan,

 

I just ran this routine on several hatched objects. I do not get an error, But I also do not get any area either. What could I be doing wrong?

 

This is what I get at the command prompt.

 

Command:
HA
Select objects: 1 found
Select objects: 1 found, 2 total
Select objects: 1 found, 3 total
Select objects:
Command:

Buzzard

 

 

I get this message now.

 

Select objects: Specify opposite corner: 6 found
3 were filtered out.
Select objects:
ActiveX Server returned the error: unknown name: Area
Command:

 

That's really strange. Hatch objects have an Area value. Could you post an example of the hatch?

[alanjt]

The code's error handler does not print error messages, so you wouldn't know if you were receiving an error.

 

Lee, I know you are just trying to help, but would you mind removing your posted code? I just don't want 2 of the same thing in here.

[The Buzzard]

That's really strange. Hatch objects have an Area value. Could you post an example of the hatch?

 

 

 

Lee, I know you are just trying to help, but would you mind removing your posted code? I just don't want 2 of the same thing in here.

 

 

This is just three hatches with rectangles.

[alanjt]

This is just three hatches with rectangles.

Works fine for me.

 

Paste the following code into ACad, select one of the hatch objects, copy and paste the return here.

 

(vlax-dump-object (vlax-ename->vla-object (car (entsel))) T)

[Lee Mac]

Works fine for me.

 

Me too.