I hate doing things I can make my computer do for me. My adventures in customizing and automating computers. Primarily with AutoCAD and Microsoft Office.

Friday, December 22, 2023

Nested Layer Control Autocad Lisp Routines

This is a group of files that will allow the user to selected nested objects for manipulating the layers: Each of the routines will allow the user to select an object. Information on the object and it's layer, including nesting information, will be shown in a dialog box. From there, the user selects the level of nesting that involves the layer he wants. Picking OK will perform the operation on the nested layer.


Sorry this is a bit rough, I was in a hurry.


Begin NestedLayerControl.lsp

;|
c:llo		turn a layer off by selecting a nested entity
c:llk		lock a layer by selecting a nested entity
c:llf		freeze a layer by selecting a nested entity
c:llu		unlock a layer by selecting a nested entity
c:llp		Set layer plotting on by selecting a nested entity
c:llnp		Set layer plotting off by selecting a nested entity


c:vplf		ViewPort Layer Freeze by selecting a nested entity
nlf		nested layer functions
ezl:nllist	dialog box routine used for nlf

|;




(defun c:llo (				;turn a layer off by selecting a nested entity
	      /				;no formal arguments
	     )				;no local variables
  (nlf "OFF" T)
  (princ)
)					;end llo

(defun c:llk (				;lock a layer by selecting a nested entity
	      /				;no formal arguments
	     )				;no local variables
  (nlf "LOCK" T)
  (princ)
)					;end llk

(defun c:llnp(				;Turn off plotting by selecting a nested entity
	      /				;no formal arguments
	      )				;no local variables
  (nlf '("P" "NoPlot") T)
  (princ)
  )

(defun c:llp(				;Turn plotting on by selecting a nested entity
	      /				;no formal arguments
	      )				;no local variables
  (nlf '("P" "Plot") T)
  (princ)
  )

(defun c:vplf(
	      /
	      )
  (nlf "VPLFREEZE" T)
  (princ)
  )

(defun c:llf (				;freeze a layer by selecting a nested entity
	      /				;no formal arguments
	     )				;no local variables
  (nlf "FREEZE" T)
  (princ)
)					;end llf

(defun c:llu (				;unlock a layer by selecting a nested entity
	      /				;no formal arguments
	     )				;no local variables
  (nlf "UNLOCK" T)
  (princ)
)					;end llU


(defun nlf (				;nested layer functions
	    which			;text string for the layer command
	    nestedp			;true to work on nested layers, nil otherwise
	    /				;end of formal argument list
	    blipmode cmdecho echo elist ent layer prmpt temp
	   )				;end of local variable list
  (cond
    ;;linetype change
    ((and (listp which) (= "L" (strcase (car which))))
     (setq
       prmpt (strcat "change to linetype " (cadr which))
       echo (strcat "changed to " (cadr which) " linetype.")
       )
     )
    ((and (listp which) (= "P" (strcase (car which))))
     (setq
       prmpt (strcat "set to " (cadr which))
       echo (strcat "Set to " (cadr which) ".")
       )
     )
    ((listp which)
     (alert "Unhandled list as argument WHICH in EZLayer nlf function.")
     )
    ((equal "OFF" which)
     (setq
       prmpt "turn off:"
       echo  "turned off."
     ) ;_ end of setq
    )
    ((equal "FREEZE" which)
     (setq
       prmpt "freeze:"
       echo  "frozen."
     ) ;_ end of setq
    )
    ((equal "LOCK" which)
     (setq
       prmpt "lock:"
       echo  "locked."
     ) ;_ end of setq
    )
    ((equal "UNLOCK" which)
     (setq
       prmpt "unlock:"
       echo  "unlocked."
     ) ;_ end of setq
    )
    ((equal "VPLFREEZE" which)
     (setq
       prmpt "freeze in current viewport:"
       echo "frozen in current viewport:"
       )
     )
    ((equal "Plot Off" which)
     (setq
       prmpt "Turn plotting off:"
       echo "Plotting turned off: ")
     )
    ((equal "Plot On" which)
     (setq
       prmpt "Turn plotting on:"
       echo "Plotting turned on: ")
     )
    (T exit)
  )					;end cond

  (cond
    ((and
       (null nestedp)
       (setq ent (entsel (strcat "Pick entity on layer to " prmpt)))
      )
     (setq
       elist (entget (car ent))
       layer (cdr (assoc 8 elist))
       )
     )					;end null nestedp
    ((and
       (setq ent (nentsel (strcat "Pick entity on layer to " prmpt)))
       (setq temp (ezl:nllist ent))
       (/= 0 (car temp))
       )				;end and
     (setq layer (cadadr temp))
     )
    (T (alert "\nInvalid value in nlp function.")(exit))
    )
					;end nestedp
    (if (and
	  (= (strcase layer) (getvar "clayer"))
	  (= which "FREEZE")
	  )
      (progn
	(princ "\nSetting current layer to 0. ")
        (setvar "clayer" "0")
      )
      )
	
    (progn
      (setq
	blipmode (getvar "blipmode")
	cmdecho	 (getvar "cmdecho")
      ) ;_ end of setq
      (setvar "cmdecho" 1);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      (setvar "blipmode" 0)
      (cond
	;;linetype
	((and
	   (listp which)
	   (member (strcase (car which)) '("L" "P"))
	   )
	 (command "layer" (car which) (cadr which) layer "")
	 )
	((listp which)
	 (alert "Unhandled list for WHICH argument in nlf function.")
	 )
	;;basic layer command
	((member which '("FREEZE" "OFF" "LOCK" "UNLOCK" ))
	 (command "layer" which layer "")
	 )
	;;vplayer freeze
	((= which "VPLFREEZE")
	 (if (= 0 (getvar "tilemode"))
	     (command "vplayer" "f" layer "" "")
	     (alert "This command must have tilemode set to 0")
	   )
	 )
	(T (alert (strcat "Invalid function name: " which " in nlf function in ezlutils.lsp")))
	)
      (setvar "blipmode" blipmode)
      (setvar "cmdecho" cmdecho)
      (princ (strcat "\nLayer " layer " " echo))
      (setvar "cmdecho" cmdecho)
      (setvar "blipmode" blipmode)
    )					;end progn
  (princ)
)					;end nlf

  


(defun ezl:nllist (				;list the layers of a nested entity
	       sellist			;list returned by nentsel
	       /			;end of formal argument list
	       elayer			;nested function
	       nlist:fill_list		;nested function
	       entlist	   llist	   dcl_id
	       listitem	   which
	      )				;end of local variable list

  (defun elayer	(			;return the entity type and layer name
		 ent			;entity name
		 /			;end of formal argument list
		 elist
		 layer
		 etype
		)			;end of local variable list
    (setq
      elist (entget ent)
      layer (cdr (assoc 8 elist))
      etype (cdr (assoc 0 elist))
      etype (cond
	      ((= "INSERT" etype)
	       (strcat
		 "Block "
		 (cdr (assoc 2 elist))
		 " insertion"
	       ) ;_ end of strcat
	      )
	      ((= "ATTDEF" etype)
	       "Attribute Definition"
	      )
	      ((= "ATTRIB" etype)
	       "Attribute"
	      )
	      ((= "BODY" etype)
	       "3D Solid"
	      )
	      (T etype)
	    ) ;_ end of cond
    )					;end setq
    (list etype layer)
  )					;end elayer

  
  
  (defun nllist:fill_list (		;fill the layers list box
			   llist	;list of layers and entity descriptions
			   listbox-key	;the key for the listbox
			   /		;end of formal argument list
			  )		;end of local variable list
    (start_list listbox-key)
    (foreach ent llist
      (add_list	(strcat
		  (cadr ent)		;layer name
		  "\t "
		  (car ent)		;entity description
		)			;end strcat
      )					;end add_list
    )					;end foreach
    (end_list)
    llist
  ) ;_ end of defun


  (if (<= 4 (length sellist))
    (setq entlist (cons (car sellist) (last sellist)))
    (setq entlist (list (car sellist)))
  ) ;_ end of if
  (setq
    llist  (mapcar 'elayer entlist)
    dcl_id (load_dialog "nllist.dcl")
  ) ;_ end of setq
  (if (not (new_dialog "setlayer" dcl_id))
    (exit)
  ) ;_ end of if

  (action_tile "layer_list" "(setq listitem $value)")
  (nllist:fill_list llist "layer_list")
  (setq
    listitem (get_tile "layer_list")
    which    (start_dialog)
  ) ;_ end of setq
  (done_dialog)
  (unload_dialog dcl_id)
  (list which (nth (atoi listitem) llist))
)					;end ezl:nllist





Begin NLList.dcl
 
    
    dcl_settings : default_dcl_settings { audit_level = 3; }
setlayer : dialog {
   initial_focus = "layer_list" ;
   key = "chlayer" ;
   label = "Select layer" ;
   : list_box {
      allow_accept = true ;
      key = "layer_list" ;
      label = "Layers" ;
      mnemonic = "L" ;
      width = 96 ;
      height = 32;
      tabs ="16 24 32";
   }
   ok_cancel ;
}

  
  

Monday, August 27, 2012

Here are some Text Justification Routines using a core routine.

This link to Justify_Text_Tools.lsp (originally by Ryan Pace) has routines for setting the justification of text/mtext objects.  The included routines are:
(defun c:JTL () (JustifyText "TL")(princ));Justify Text to top left
(defun c:JTR () (JustifyText "TR")(princ));Justify Text to top right
(defun c:JTC () (JustifyText "TC")(princ));Justify Text to top center
(defun c:JML () (JustifyText "ML")(princ));Justify Text to middle left
(defun c:JMR () (JustifyText "MR")(princ));Justify Text to middle right
(defun c:JMC () (JustifyText "MC")(princ));Justify Text to middle center
(defun c:JBL () (JustifyText "BL")(princ));Justify Text to bottom left
(defun c:JBR () (JustifyText "BR")(princ));Justify Text to bottom right
(defun c:JBC () (JustifyText "BC")(princ));Justify Text to bottom center
As you can see, each of the routines calls the JustifyText routine with an argument telling it which justification to use.  This allows us to use the one core routine for multiple tools so if we ever have to update the routines we only have to update the JustifyText sub-routine.
(defun JustifyText(mode / *ERROR* cmdecho)
  (defun *ERROR*(msg)
    (command)
    (command)
    (command)
    (if cmdecho (setvar "cmdecho" cmdecho))
    (princ msg)
  )
  (setq cmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (cond
    ((null (setq ss1 (vl-catch-all-apply 'ssget (list '((0 . "Text,Mtext,Attdef"))))))
      nil
    )
    ((vl-catch-all-error-p ss1)
      (princ (strcat "\nERROR|" (vl-catch-all-error-message ss1)))
      nil
    )
    ((and
        (= 'PICKSET (type ss1))
        (= 0 (sslength ss1))
      )
      nil
    )
    (T(command "_justifytext" ss1 "" mode))
  )
  (setvar "cmdecho" cmdecho)
  ss1
)

Thursday, August 23, 2012

EZOffset and leveraging a code snippet to create multiple routines

It's been a while.

Since I am emailing tips to my coworkers I thought I would start posting some of the background on those tips.

This is a link to EZOFFSET.LSP which has the following aliases for offsetting specific distances:


;;;  Offsets by sixteenths of an inch  -  OF (the "F" is for fraction") followed by the number of 16ths you want to offset
OF1        offset 1/16"
OF2        offset 2/16"   (1/8")
OF3        offset 3/16"
OF4        offset 4/16"   (1/4")
OF5        offset 5/16"
OF6        offset 6/16"   (3/8")
OF7        offset 7/16"
OF8        offset 8/16"   (1/2")
OF9        offset 9/16"
OF10      offset 10/16"  (5/8")
OF11      offset 11/16"
OF12      offset 12/16"  (3/4")
OF13      offset 13/16"
OF14      offset 14/16"  (7/8")
OF15      offset 15/16"

;;;  Offsets by inches - O followed by the number of inches you want to offset.  This has some variations shown below in red.
O1          offset 1"
O1F4      offset 1 4/16"  (1 1/4")
O1F8      offset 1 8/16"  (1 1/2")
O1F12   offset 1 12/16" (1 3/4")
O2          offset 2"
O3          offset 3"
O3F8      offset 3 8/16" (3 1/2")
O4          offset 4"
O5          offset 5"
O5F8      offset 5 8/16" (5 1/2")
O6          offset 6"
O7          offset 7"
O8          offset 8"
O9          offset 9"
O10        offset 10"
O11        offset 11"
O12        offset 12"
O13        offset 13"
O14        offset 14"
O15        offset 15"
O16        offset 16"
O17        offset 17"
O18        offset 18"
O19        offset 19"
O20        offset 20"
O21        offset 21"
O22        offset 22"
O23        offset 23"
O24        offset 24"
O30        offset 30"
O36        offset 36"
O42        offset 42"
O48        offset 48"
O60        offset 60"
O72        offset 72"
O84        offset 84"
O96        offset 96"
O108      offset 108"  (9')
O120      offset 120"  (10')
O132      offset 132"  (11')
O144      offset 144"  (12')
O156      offset 156"  (13')
O168      offset 168"  (14')
O180      offset 180"  (15')
O240      offset 240"  (20')
O360      offset 360"  (30')
O480      offset 480"  (40')

The meat of the code is thus:

(defun ezoffset(
                dist
                /
                offsetdist
                )
  (setq offsetdist (getvar "offsetdist"))
  (setvar "offsetdist" dist)
  (command "offset" dist)
  (while (wcmatch (getvar "cmdnames") "*offset*")
    (command pause)
    )
  (setvar "offsetdist" offsetdist)
  (princ)
  )
(princ)
)
and can be called, like this:

(defun c:OF1()(ezoffset 0.0625))  ;offset 1/16"
(defun c:OF2()(ezoffset 0.125))   ;offset 2/16"   (1/8")



The naming conventions I have used for these routines are arbitrary, but they work for me.

Let me know if you find these useful.

Monday, May 25, 2009

Number base conversion - optimized

This is a second iteration on my previous post.

    Seconds for 25,000 Iterations    
Number Base ToBase10 ToBase10-2 Change
1111 2 1.08 0.656 -40%
1523 6 1.09 0.547 -50%
15A23 26 1.86 0.703 -38%

Take the above for what it’s worth.  If this is a time critical conversion and you have tight control over the number being converted – you may opt for using ToBase10-2 and wrapping it in a vl-catch-all-apply.  Either way, it’s your call.

(defun ToBase10-2(NumBase InputValue / )
       (
setq
      
indx      0
      
;;Get the list of multipliers
       temp (mapcar
         
(function
       
(lambda    (x)
          (
if (< 57 x)
            (
- x 55)
            (
- x 48)
          )
        )
          )
          (
reverse (vl-string->list
            
(if (= 'INT (type InputValue))
               (
itoa InputValue)
              
InputValue
            
)
               )
          )
        )
      
rtval      0
    
)
     (
repeat (length temp)
       (
setq
    
digit (nth indx temp)
    
rtval (+ rtval (* Digit (expt NumBase indx)))
    
indx  (1+ indx)
       )
     )
    
rtval
 
)

Number base conversion

This routine will convert a number from any base between 2 and 36, inclusive, to base 10.

  Routine:    ToBase10
  Purpose:    Convert a number from any base between 2 and 36 to base 10
  Arguments:    NumBase - integer where 2<= NumBase <= 36.  The number base from which we are
            converting.
          InputValue
            Symbol - example: '010010
            Number - example:   10010
            string - example: "010010" or "10010"
  Returns:    The input value converted to base 10
=============================================================================================
  This routine is the inverse of the base routine found in the acad developement help files
    under "ASCII Code Conversion", hence, (tobase10 16 (base 16 5284)) returns 5284
---------------------------------------------------------------------------------------------
  Example1:    (tobase10 2 '11001011 )  returns      203
  Example2:     (tobase10 2  11001011 )  returns      203
  Example3:     (tobase10 2 "11001011")  returns      203

  Example4:     (tobase10 6 '15243 )     returns     2475
  Example5:     (tobase10 6  15243 )     returns     2475
  Example6:     (tobase10 6 "15243")     returns     2475

  Example7:     (tobase10 16 '34F1A )    returns   216858
  Example9:     (tobase10 16 "34F1A")    returns   216858
    Notice that '34F1A cannot be represented as a number, hence, only two examples

  Example10:    (tobase10 36 '11001011 ) returns 60525828
  Example11:    (tobase10 36  11001011 ) returns 60525828
  Example12:    (tobase10 36 "11001011") returns 60525828
    As a check, use this online java applet.

 

(defun ToBase10 (NumBase InputValue / rtval)

;;Here we convert out input value’s type.
  (
cond
   
((= 'str (type inputvalue))
     (
setq inputvalue (strcase inputvalue))
     )
    ((
= 'SYM (type inputvalue))
     (
setq InputValue (vl-symbol-name InputValue))
     )
    )

;;Here we start validating our input
  (
cond
   
;;Base is not an integer
    ((not (= 'int (type NumBase)))
     (
strcat
      
"ERROR|ToBase10 base argument must be an integer - "
      
(vl-prin1-to-string (type NumBase))
      
" provided (" (vl-prin1-to-string NumBase) ")"
      
)
     )
   
;;Base argument is out of range
    ((or
      
(> 2 NumBase)
       (
< 36 NumBase)
       )
     (
strcat
      
"ERROR|ToBase10 Base argument must be greater than 1 and less than 36 - " (itoa NumBase) " provided."
      
)
     )
   
;;InputValue is of wrong type for specified base
    ((and
      
(> NumBase 10)
       (
not (= 'STR (type InputValue)))
       )
      
"ERROR|Numbers in a base greater than 10 must be expressed as a string - ToBase routine."
   
)
   
;;InputValue has invalid characters
    ((not (vl-every
       
(function
         
(lambda (asciicode)
        (
cond
         
;;Character below "0" used
          ((< asciicode 48) nil)
         
;;Character greater than valid used for base less than or equal to 10
          ((and
            
(<= NumBase 10)
             (
> asciicode (+ 47 NumBase))
             )
          
nil
          
)
         
;;For base greater than 10, invalid character used
          ((and (> NumBase 10)
            (
not (wcmatch (chr asciicode) (strcat "[0-9],[A-" (chr (+ NumBase 54)) "]")))
            )
          
nil
          
)
          (
T T)
          )
        )
          )       
        (
vl-string->list (if (= 'INT (type InputValue))
                   (
itoa InputValue)
                  
InputValue
                  
)
          )
      )
     )
     (
strcat
      
"ERROR|Invalid InputValue argument provided to ToBase10 routine : " (vl-prin1-to-string InputValue)
     )
    )

;;Now we’re done validating the input, let’s get started
    (
T
    
(setq
      
indx      0
      
;;Get the list of multipliers
       temp (mapcar
         
(function
       
(lambda    (x)
          (
if (< 57 x)
            (
- x 55)
            (
- x 48)
          )
        )
          )
          (
reverse (vl-string->list
            
(if (= 'INT (type InputValue))
               (
itoa InputValue)
              
InputValue
            
)
               )
          )
        )
      
rtval      0
    
)
     (
repeat (length temp)
       (
setq
    
digit (nth indx temp)
    
rtval (+ rtval (* Digit (expt NumBase indx)))
    
indx  (1+ indx)
       )
     )
    
rtval
   
)
  )
)

The concept for this approach was derived from here - chapter IX.

Friday, April 24, 2009

Bulk Rename Utility

I am working on a project that involves renaming many xref drawing files.  To deal with redirecting all of the references to these files I have created a routine that reads a list of old reference drawing names and new reference drawing names from a tab delimited text file.  The lisp routine then renames each reference to each of the redirected files and changes the path to point to the renamed drawing.  The intention is that this routine will be run by the s::startup routine when a drawing opens.  This allows us to simply add an entry to the redirection list and it will be handled the next time any referencing drawings are opened.

Yesterday I was faced with the task of renaming about 50 of these xref drawing files in one shot.  Enter “Bulk Rename Utility”.  Bulk Rename Utility is a free file renaming tool allowing you to easily rename files and entire folders based upon extremely flexible criteria.  A look at a screenshot (here) gives an idea just how many options there are.  This utility not only allowed me to rename these 50 files in one quick shot, but also gave me a tab delimited list of the old name and new name pairs.  This list will go directly into my xref redirection list with very little additional tweaking.

Kudos to a great piece of free software.  Download it here:http://www.bulkrenameutility.co.uk/Main_Intro.php

Wednesday, April 22, 2009

Get all insertions of a block

Note: this process will not correctly identify insertions of dynamic blocks. - mweaver 01/18/2019
Let’s look at a way to get all insertions of a block without using ssget and without iterating through all objects in the drawing.  This method will also get nested block insertions.
Let’s say the block we want is named “Test2”.
We can use tblobjname to get the block definition entity, thus:
(tblobjname "block" "test2")
This will get us an entity name which we can run through entget to get the following:
((-1 . <Entity name: 7ee414c8>)
  (0 . "BLOCK")
  (330 . <Entity name: 7ee414c0>)
  (5 . "181")
  (100 . "AcDbEntity")
  (67 . 0)
  (8 . "0")
  (100 . "AcDbBlockBegin")
  (70 . 0)
  (10 0.0 0.0 0.0)
  (-2 . <Entity name: 7ee414d0>)
  (2 . "test2")
  (1 . "")
)
Here we have the beginning of the block definition – the objects that make up the block.  If we do an entget on the entity name at assoc 330, we get something like the following:
((-1 . <Entity name: 7ee414c0>)
  (0 . "BLOCK_RECORD")
  (330 . <Entity name: 7ee3fc08>)
  (5 . "180")
  (100 . "AcDbSymbolTableRecord")
  (100 . "AcDbBlockTableRecord")
  (2 . "test2")
  (360 . <Entity name: 7ee414c8>)
  (340 . <Entity name: 0>)
  (102 . "{BLKREFS")
  (331 . <Entity name: 7ee414e8>)
  (331 . <Entity name: 7ee41540>)
  (102 . "}")
  (70 . 1)
  (280 . 1)
  (281 . 0)
)
Note the 331 entries.  These are the entity names for each insertion of Test2.
This approach has distinct advantages over ssget, primarily because this will show nested insertions.  Also, with a bit of trickery, this can be used with objectdbx documents – avoiding the need to iterate every object in the drawing looking for block insertions.
For more information see my entry on Getting block insertions with objectdbx.

Saturday, April 18, 2009

Gathering attributes from a block insertion

In an earlier post I showed a routine for gathering attributes from a block insertion object.  I have since found a better way to get the attribute objects.

For years I have been using vla-get-attributes, which returns a variant, which must then be converted to a safearray and then a list.  The “New and Improved” method is to use vlax-invoke.

Below are a couple of test procedures I used to benchmark these two methods.

First, I selected the block insertion and converted the entity name to a vla object.

(setq obj (vlax-ename->vla-object(car (entsel))))

Here are the two functions.  AttTest1 using vla-getattributes, and AttTest2 using vlax-invoke.  Note that the functions are defined using Defun-q rather than Defun.  This is because the benchmarking routine I used (by Vladimir NesterovskyProfiler) requires defun-q.  I typically change the defun to defun-q to run the profiler, then change it back.

(defun-q attTest1
     ()
     (vlax-safearray->list
       (vlax-variant-value
         (vla-getattributes obj)
       )
     )
     (princ)
)

(defun-q attTest2
     ()
     (vlax-invoke obj 'getattributes)
     (princ)
)

Now for the fun part. Profile-Func is a routine in Vladimir’s profiler that registers the function and starts the timer.

(profile-func 'attTest1)
(profile-func 'attTest2)

Below are the timer results after running both routines 10 times.

Routine

Number of runs timed

Total seconds for all runs

Average seconds per run

AttTest1 10 0.4 0.041
AttTest2 10 0.07 0.007

To put this in perspective, the test block I created for this has 10,000 attributes.  That’s 0.00007 milliseconds per attribute!  Not too shabby!  Needless to say, I am going to be using vlax-invoke to get block attributes on all my routines in the future.  In addition I am going to be looking much more closely at the vlax functions.  I am particularly interested in using vlax-invoke with the GetDynamicBlockProperties method.

Wednesday, April 08, 2009

A Free copy of AutoCAD? From Autodesk???

Jimmy Bergmark, over at JTBWorld posted an article pointing out the Autodesk Assistance Program. This program makes a copy of AutoCAD 2010 available to qualified applicants. If you are a recently un-employed AutoCAD user, check this out!

Tuesday, April 07, 2009

AssocOn other than the car

Have you ever wanted to use Assoc to select an item out of a list, but the search term you wanted to use wasn't the car of the elements of the list? Enter AssocOn. This will let you do an "assoc-like" search on any element of the sub-lists. Take a look at the examples below.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  Routine:    AssocON                                
;;;  Purpose:    Similar to Assoc, but uses a user specified function to select    
;;;          the item in the list on which to search instead of        
;;;          searching on the car of the list.                
;;;  Arguments:    SearchTerm, the item for which we are searching.        
;;;        Lst, the list of lists through which we are searching.        
;;;        func, the function we are using to specify the item in the    
;;;          sub-list.                            
;;;  Returns: the sub-list with the first match.                ;;;
;;;=============================================================================
;;;  Examples                                    
;;;  Given:  (setq mylist '((1 2 3 4 5) (7 6 5 4 3 2 1) (12 13 14 15)))        
;;;        (assocon 2 mylist 'cadr)                        
;;;    will return                                
;;;       (1 2 3 4 5)                                
;;;                                        
;;;    and                                    
;;;                                        
;;;       (assocon "2" mylist                            
;;;        (function (lambda(x)(itoa (cadr x))))                
;;;       )                                    
;;;    will return                                
;;;       (1 2 3 4 5)                                
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun AssocOn (SearchTerm Lst func /)
  (
car
    
(vl-member-if
      
(function
    
(lambda (pair) (equal SearchTerm (apply func (list pair))))
      )
      
lst
    
)
  )
)

Wednesday, April 01, 2009

Get block insertions with objectdbx

Routine: GetBlockInserts  
Purpose:   Get a list of all insertions of specified blocks.
Arguments: doc vla-document object (or objectdbx document). If nil, then the active document is used.           
  bnames a list of strings, the block names for the subject blocks.
  ReturnEnames boolean, non-nil returns entity names, nil returns vla-objects.
Returns:   A list of all the insertions of the subject blocks. -1 if the block is not defined. Nil if the block is defined but has no insertions.

Calling GetBlockInserts thus:

(getblockinserts2 nil '("test1" "test2" "test3") nil)

Might return something that looks like this:

(("test1"
   #<VLA-OBJECT IAcadBlockReference 0b4b55c4>       ;These may be enames or vla-objects depending on ReturnEnames
   #<VLA-OBJECT IAcadBlockReference 0b4b52f4>
   #<VLA-OBJECT IAcadBlockReference 0b4b56b4>
   #<VLA-OBJECT IAcadBlockReference 0b4b563c>
   #<VLA-OBJECT IAcadBlockReference 0b4b518c>
   #<VLA-OBJECT IAcadBlockReference 0b4b554c>
   #<VLA-OBJECT IAcadBlockReference 0b4b54d4>
  )
  ("test2"
   #<VLA-OBJECT IAcadBlockReference 0b4b57a4>
   #<VLA-OBJECT IAcadBlockReference 0b4b53e4>
   #<VLA-OBJECT IAcadBlockReference 0b4b536c>
   #<VLA-OBJECT IAcadBlockReference 0b4b545c>
  )
  ("test3"
    #<VLA-OBJECT IAcadBlockReference 0b4b527c>
    #<VLA-OBJECT IAcadBlockReference 0b4b5204>
    #<VLA-OBJECT IAcadBlockReference 0b4b4dcc>
    #<VLA-OBJECT IAcadBlockReference 0b4b4fac>
    #<VLA-OBJECT IAcadBlockReference 0b4b509c>
   )
("test4")                                           ;There are no insertions of this block
("test5" . –1)                                      ;This block is not defined
)

Note that (cdr(assoc “test4” results)) will return nil.

 

(defun GetBlockInserts2    (doc bnames ReturnEnames / objBlockDef InsList Blocks)
  (
setq    doc    (if doc
         doc
        
(vla-get-activedocument (vlax-get-acad-object))
           )
   
blocks (vla-get-blocks doc)
  )
  (
mapcar (function (lambda (bname)
              (
setq inslist nil)
              (
cons bname
               
(if    (vl-catch-all-error-p
                 
(setq    objBlockDef
                    
(vl-catch-all-apply 'vla-item (list blocks bname))
                  )
                )
                 
-1    ; Block doesn't exist
                  (setq InsList (vl-remove-if-not
                     
(function
                       
(lambda (x) (and (= 331 (car x)) (entget (cdr x))))
                          )
                          (
member '(102 . "{BLKREFS")
                              (
entget (vlax-vla-object->ename objBlockDef))
                          )
                        )
                   
inslist (if    ReturnEnames
                         
(mapcar (function (lambda (x) (cdr x))) inslist)
                          (
mapcar
                       
(function (lambda (x) (vlax-ename->vla-object (cdr x)))
                        )
                       
inslist
                         
)
                        )
                  )
                )
              )
            )
      )
     
bnames
 

)
)

Modified 4/24/2009

Monday, March 30, 2009

Close with save - all drawings except current

This will close all currently open drawings, saving those that have been modified since their last save.

(vlax-for doc (vla-get-documents(vlax-get-acad-object))
  (
if (doc (vla-get-activedocument(vlax-get-acad-object)))
    
nil
    
(progn
      
(if (or
        
((getvar "dbmod"))
        (
= :vlax-false (vla-get-readonly doc))
        )
    (
vl-catch-all-apply 'vla-close (list doc :vlax-false))
    (
vl-catch-all-apply 'vla-close (list doc :vlax-true))
    )
      )
    )
  )

Friday, March 27, 2009

Rename xrefs to match their filename

(vl-load-com)
(
setq
  
doc (vla-get-activedocument(vlax-get-acad-object))
  
blocks (vla-get-blocks doc)
)
(
vlax-for blk blocks
  
(if (not
    
(vl-catch-all-error-p
      
(vl-catch-all-apply 'vla-get-path (list blk))
    )
      )
    (
vla-put-name blk (vl-filename-base (vla-get-path blk)))
  )
)

Saturday, March 21, 2009

GatherAtts.lsp

Function: gatheratts
Purpose Gathers all the attributes and their values into a list for all insertions of specified blocks.
Arguments bnames  list of block names to find
Returns

list of lists Organized by block name as follows:
((bname1  the name of the first block
  (bref1 atts) the bref object followed by a list of attrib objects
  (bref2 atts) the bref object followed by a list of attrib objects
)
(bname2  the name of the second block
  (bref3 atts) the bref object followed by a list of attrib objects
  (bref4 atts) the bref object followed by a list of attrib objects
)

(defun gatheratts (bnames / ;end of formal argument list
               rtlist          gatheratts     ;the list to return
               inslist              ;list of block insertions
               attlist atts indx objins ss1 ssl ssp)
                                   
;end of local variable list
(setq
ssp    (ssgetfirst)
bnames (mapcar '(lambda (s) (strcase s)) bnames)
)
(
foreach bname bnames
(cond
 
;;Let's see if this block has any insertions
  ((null (setq ss1 (ssget "X" '((0 . "INSERT")))))
  
nil                              ;no selection set created, return nil
  )
 
;;How many insertions?
  ((= 0 (setq ssl (sslength ss1)))
  
nil                              ;no insertions, return nil
  )
 
;;  We found insertions, lets build a list of their attributes
  (T
  
(setq
    
indx -1                        ;initialize our index
     inslist nil
  
)                                ;end setq
   ;;get all the insertions for this block
   (while (> ssl (setq indx (1+ indx)))


     (
cond
      
;;stop this object here if it has not attributes
       ((= :vlax-false
          
(vla-get-hasattributes
            
(setq objIns
                   
(vlax-ename->vla-object (ssname ss1 indx))
             )
           )
        )
       
nil
      
)
       ((
not (or
              
;;it's an un-modified dynamic block or non-dynamic block
               (= bname (strcase (vla-get-name objins)))
              
;;it's a dynamic block
               (= bname (strcase (vla-get-effectivename objins)))
             )                     
;end or
        )                           ;end not
        nil                         ;it isn't one of our blocks, ignore it
       )


       (
T                           ;do this to every object that gets by our test
        (setq
         
atts    (vla-getattributes objIns)
         
attlist (vlax-safearray->list (vlax-variant-value atts))
                                   
;the attributes in a list
          attlist (mapcar
                   
'(lambda (a) (cons (vla-get-tagstring a) a))
                   
attlist
                 
)
         
inslist (append inslist (list (cons objins attlist)))
        )                          
;end setq
       )                            ;end T
     )                              ;end cond



   )                                ;end while insertions still found for this block name
   ;;add the lists for the insertions of this block to the return list
   (setq rtlist (append rtlist (list (cons bname inslist))))
  )                                
;end T
)                                   ;end cond
)                                     ;end foreach
(sssetfirst (car ssp) (cadr ssp))
rtlist                                ;return the list of lists of lists of lists of lists...
)                                       ;end of gatheratts

(Edited 4/18/2009 to improve formatting)

Monday, February 19, 2007

CAD runs slower on Vista?

UpFrontEZine reports that "Vista Runs CAD (up to) 50x Slower". See Ralph Grabowski's upFront.eZine for details.

After attending the Vista launch event, I was hoping performance would improve. I guess not. At least, not for a while:-(

Tuesday, February 06, 2007

Hide blank lines in excel

When I need to hide blank lines in excel I use the following. First I select a range then run the following macro. This will hide all lines in the selected range which have no numerical values. This is pretty simplistic and has virtually no error checking, but it does what I need and I thought it might be helpful for others.

Public Sub HideBlankLines()
Dim rngLine As Range
Dim rngCell As Range
Dim bolNonBlankFound As Boolean

Application.ScreenUpdating = False

For Each rngLine In Application.Selection.Rows
bolNonBlankFound = False
For Each rngCell In rngLine.Columns
If Len(rngCell.Text) > 0 Then bolNonBlankFound = True: Exit For
Next rngCell
If Not bolNonBlankFound Then rngLine.EntireRow.Hidden = True
Next rngLine

Application.ScreenUpdating = True


End Sub

Monday, May 08, 2006

More HPFeet - Plate Weight

This is a small routine to calculate the weight of steel plates using my HPFeet input method. Example:
0.25 enter (the plate thickness in inches)
12 enter (the plate width in inches)
12.0108 (the plate length in HPFeet - in this case 12'-1 1/2")
PLWT (the procedure call)
123.7760 (the result - 123.7760 lbs)

The code:
FTD 12. * * * 12 / 12 / 12 / 490 *

Wednesday, May 03, 2006

Feet and inches with HP calculators

In the early 1980's I was introduced to the HP 41C programable calculator and was introduced to a series of small programs that perform basic math functions on imperial measurements without having to convert to decimal. To do this, distances are represented by what I will refer to as HPFeet, thus: FF.IISS where FF = whole feet, II = whole inches, and SS = sixteenths of an inch. In this format, 12'-1 1/2" is represented as 12.0108. The basic math functions, as I now use in an HP 48GII follow.

FTD: Feet to Decimal - Converts FF.IISS to decimal feet. For example, 12.0108 (which represents 12'-1 1/2") becomes 12.125
DUP IP SWAP FP 100 * DUP IP 12 / ROT + SWAP FP 100 * 16 / 12 / +

DTF: Decimal to feet - Converts decimal feet and inches in my HPFeet.
DUP IP SWAP FP 12 * DUP IP SWAP FP 16 * 100 / + 100 / +

FADD: With HPFeet numbers in both the first and second stack positions, the following will add them together leaving the result in the first stack position as HPFeet.
FTD SWAP FTD + DTF

FMIN: With HPFeet numbers in both the first and second stack positions, the following will subtract the first from the second, leaving the result in the first stack position as HPFeet.
FTD NEG SWAP FTD + DTF

FMULT: With an HPFeet number in both the second stack position and a decimal number in the first stack position, the following will multiply them, leaving the result in the first stack position as HPFeet.
SWAP FTD * DTF

FDIV: With an HPFeet number in both the second stack position and a decimal number in the first stack position, the following will divide the second by the first, leaving the result in the first stack position as HPFeet.
INV SWAP FTD * DTF

Later, I will include a couple more functions along with key assignments that simplify the use of the above routines.

Tuesday, May 02, 2006

Coming online!

This being my first post, I will try to give you an idea what to expect.

I have been using computers since about 1988 and programmable calculators (HP 41 and Ti-74) since about 1983. In that time I have worked as a steel detailer (one who creates steel fabrication drawings), a structural designer, an architectural drafter and designer. I have used AutoCAD since release 10 along with Excel and Lotus 123 since 1988. I am fascinated by the ability to make computers work for us. Because of this I have been programming since introduced to the HP 41C calculator in the early 80s. I expect to post my experiences as I continue to program Excel and AutoCAD using VBA, Lisp, and maybe even some dotNet.