Leaderboard

For Bricscad its "Print as PDF.pc3" but if you have a plot lisp can get which software is being used and set correct output. (if (wcmatch (getvar 'acadver) "*BricsCAD*" ) (setq printer "Print as PDF") (setq printer "Plot to PDF") ) Don't need Pc3 but I did copy "Publish to web PNG.pc3" from Acad to correct location but it returns not supported in my Bricscad. Not sure if later Versions have a PNG output.

You as Well!

My friend there is no rush. i've been doing this manually for years lol. I break up from work tomorrow evening for a week also. Have safe travels.

@Sharper Ok thanks for the answers. It should not be too much effort to write this for you. Just to let you know however, I'll be out of communication for the next 5 or 6 days since I'll be on Holiday. I will get on this afterwards. If I get any time tonight I might get to it sooner, but I'll be traveling tomorrow morning.

No worries pkenewell. It seems the dimension text is constantly changing handles when edited with its own reactor. We'll see if some other CAD masters may have something to suggest.

@Sharper you in good hands with pkenewell This legend has made my work life so much better. @pkenewell I send my appreciation again.

Try to change the line 232 in the code to OK (apply 'append (mapcar '(lambda (x) (mapcar '(lambda (zx) (equal (list (car x) (cadr x)) (list (car zx) (cadr zx)) 5E-02)) l_z)) (list pt_start pt_end))) I haven't test 'it!

You're right, it's buggy in this specific case. Your tip is good If I want to apply your tip to the code I would add after line 46 (if (equal in in2 1E-08) (setq in2 (+ in2 1E-07))) because I am doing a test from line 114 to 126 to 1E-08 on the inter-distance and if in = in2; it erases everything. Which explains why only the last segment remains. This modification may be enough because modifying my code would become more complicated. This would be another algorithm and it's worth my time... Is this only for a representation? 1E-07 is really little and is sufficient for a representation of discontinuity.

Thank you very much for your help. This is exactly what I needed. I will learn from the code you modified

The "3" option is not listed when giving the UCS command. It can be entered but it is not needed. The user should just give the UCS command and, with osnap end active, click on the three points I outline above to create a UCS on the plane of the end of an existing weld bead. @Emboss 2014 no need to "rotate" the UCS. Just use the UCS command and 3 points. If the resulting UCS does look correct to use then use orbit (I like 3forbit) to visually verify that the XY plane of the ucs is on the plane of the weld end. Command: UCS Current ucs name: *NO NAME* Specify origin of UCS or [Face/NAmed/OBject/Previous/View/World/X/Y/Z/ZAxis] <World>:

Hi all, Here's the code I have to hatch items inside blocks with a wipeout layer. Handy for furniture and the like. I was wondering if there was a more robust way of selecting objects in the block editor to hatch them. See line: (setq ssObj2Hat (ssget "_X" '((0 . "~*TEXT") (0 . "~ATTDEF")))) ;; Select all but TEXT, MTEXT or ATTDEF (Testing) I've removed all text and attributes because they're those objects I would like to remove. I'd like to get your guys thoughts on how best to tackle this, thanks. If nothing else share this with you all (vl-load-com) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; BK_Hatch_Solid_With_Wipeout.lsp ;; Hatches objects inside blocks with a SOLID hatch and on the "GN_wipe-out" layer. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Based on code by Tharwat 18th Sept 2013 ;; https://www.cadtutor.net/forum/topic/46782-deleting-hatch-from-blocks/?do=findComment&comment=396412 ;; ;; First modified on 2022.12.12 by 3dwannab to hatch everything inside the block. Help over here: https://www.cadtutor.net/forum/topic/76450-hatch-objects-inside-a-block/ ;; Last modified on 2024.05.22 by 3dwannab ;; ;; Requires the _createOrUpdateLayer function located in the acaddoc.lsp file. ;; ;; TO DO: Only hatch entities that can be hatched. Think there may be a vla-get for this. Not sure. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun c:BKHatch_Solid_With_Wipeout (/ *error* acDoc blkn cnt i layerName obj ssHatches ssIns ssObj2Hat var_cmdecho var_osmode) (defun *error* (errmsg) (and acDoc (vla-EndUndoMark acDoc)) (and errmsg (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*")) (princ (strcat "\n<< Error: " errmsg " >>\n")) ) (setvar 'cmdecho var_cmdecho) (setvar 'osmode var_osmode) ) ;; Start the undo mark here (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc)) ;; Get any system variables here (setq var_cmdecho (getvar "cmdecho")) (setq var_osmode (getvar "osmode")) (setvar 'cmdecho 0) (setvar 'osmode 0) (setq layerName "GN_wipe-out") (prompt (strcat "\nSelect BLOCKS to solid hatch in the layer '" layerName "' :\n")) (if (setq ssIns (ssget "_:L" '((0 . "INSERT")))) (progn (setq cnt 0) (repeat (setq cnt (sslength ssIns)) (setq cnt (1- cnt)) (setq blkn (cons (vla-get-effectivename (vlax-ename->vla-object (_dxf -1 (entget (ssname ssIns cnt))))) blkn)) ) (setq blkn (_removedup blkn)) (foreach x blkn (command "-bedit" x) (setvar 'cmdecho 0) ; Set this inside block editor just in case. (setvar 'osmode 0) ; Set this inside block editor just in case. (setq ssHatches (ssadd)) ; (setq ssObj2Hat (ssget "_X" '((0 . "LWPOLYLINE") (-4 . "<OR") (70 . 1) (70 . 129) (-4 . "OR>")))) ;; Select closed polylines (setq ssObj2Hat (ssget "_X" '((0 . "~*TEXT") (0 . "~ATTDEF")))) ;; Select all but TEXT, MTEXT or ATTDEF (Testing) (if ssObj2Hat (progn ;; Create the wipe out layer (_createOrUpdateLayer layerName '(254 254 254) "Continuous" acLnWt025 0 :vlax-true "Craftstudio Layer - General Layer: Useful for furniture and other movable objects to obscure whats behind") (command "_.-hatch" "_P" "_S" "_LA" "." "_advanced" "_associativity" "_yes" "" "_select" ssObj2Hat "" "") ;; Add the created hatches to a selection set. (setq ssHatches (ssadd (entlast) ssHatches)) ;; Loop through selected objects and set properties (repeat (setq i (sslength ssHatches)) (setq obj (vlax-ename->vla-object (ssname ssHatches (setq i (1- i))))) ;; Set the hatch objects to the correct properties for the 'GN_wipe-out' layer. (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Layer (list obj layerName))) (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Linetype (list obj "ByLayer"))) (vla-put-LineWeight obj aclnwtbylayer) (vla-put-Color obj acbylayer) (vla-put-LinetypeScale obj 1) (vla-put-EntityTransparency obj "ByBlock") ) ;; Send behind the selected objects. (command "_.draworder" ssHatches "" "_U" ssObj2Hat "") ) ) ; if ssObj2Hat (command "_.bsave") (command "_.bclose") (redraw) ) ; foreach ) ; progn ) (if ssIns (progn (princ (strcat "\n: ------------------------------\n\t\t<<< " (itoa (sslength ssIns)) (if (> (sslength ssIns) 1) " <<< BLOCKS" " <<< BLOCK") " solid hatched with layer '" layerName "'\n: ------------------------------\n")) (sssetfirst nil ssIns) (command "_.regen") ) ) (vla-EndUndoMark acDoc) (*error* nil) (princ) ) ;; removes duplicate element from the list (defun _removedup (l) (if l (cons (car l) (_removedup (vl-remove (car l) (cdr l)))) ) ) ;;----------------------------------------------------------------------;; ;; _dxf ;; Finds the association pair, strips 1st element ;; args - dxfcode elist ;; Example - (_dxf -1 (entget (ssname (ssget) 0))) ;; Returns - <Entity name: xxxxxxxxxxx> (defun _dxf (code elist) (cdr (assoc code elist)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; _createOrUpdateLayer ;; ;; Creates a new layer or updates an existing one if it exists. ;; Will attempt to load the linetype if found in the acad*.lin file and if the layer exists, it will update the properties. ;; Original code by ronjonp, taken from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-layer-with-true-color-in-lisp/m-p/7904814#M367339 ;; ;; USAGE: ;; (_createOrUpdateLayer "Test1" 22 "Dashed" aclnwtbylwdefault 33 :vlax-true "Test1 Description") ;; (_createOrUpdateLayer "Test2" '(100 150 200) "Continuous" aclnwtbylwdefault 33 :vlax-false "Test2 Description") ;; ;; The :vlax-true or :vlax-false in examples above is for plot on or off. ;; The 33 values represent the transparency of the layer. ;; Original help from mhupp here to get it to update layer if it exists: https://www.cadtutor.net/forum/topic/75414-defun-to-create-or-update-layers-not-updating-them/?do=findComment&comment=596266 ;; ;; ARGUMENTS: ARGUMENTS SYTAX: ;; 1st arg: Layers Name = STRING ;; 2nd arg: Layers Colour = 22 or '(100 150 200) (Can be an indexed colour or true colour) ;; 3rd arg: Layers Linetype = STRING ;; 4th arg: Layers Lineweight = acLnWtByLayer, acLnWtByBlock, acLnWtByLwDefault, acLnWt000, acLnWt005, acLnWt009, acLnWt013, acLnWt015, acLnWt018, acLnWt020, acLnWt025, acLnWt030, acLnWt035, acLnWt040, acLnWt050, acLnWt053, acLnWt060, acLnWt070, acLnWt080, acLnWt090, acLnWt100, acLnWt106, acLnWt120, acLnWt140, acLnWt158, acLnWt200, acLnWt211 ;; 5th arg: Layers Transparency = INTEGER (Between 0-90) ;; 6th arg: Layers is Plottable on not = :vlax-true = Plottable or :vlax-false = Not Plottable ;; 7th arg: Layers Description = STRING ;; ;; For Linewiight in vlisp, see this reply by CAB: https://www.theswamp.org/index.php?topic=22438.msg270124#msg270124 ;; ;; MODIFICATIONS: ;; New code By Leemac with small modifications by 3dwannab. ;; Modified by 3dwannab on 2024.05.22 to add if the layers is plottable and also added the possibility to add a description to the layer. ;; Lee Macs code: https://www.cadtutor.net/forum/topic/66765-vla-put-truecolor/?do=findComment&comment=546879 ;; Modified by 3dwannab on 2024.05.22 to add transparency, description and plot to Lee Macs function. ;; Help from mhupp here to get it to update layer if it exists: https://www.cadtutor.net/forum/topic/75414-defun-to-create-or-update-layers-not-updating-them/?do=findComment&comment=596266 (defun _createOrUpdateLayer (name color linetype lineweight transparency plottable description / _loadlinetype lay tru) ;; Credit to Grr1337 ;; https://www.theswamp.org/index.php?topic=52473.msg574008#msg574008 ;; (_SetLayerTransparency (getvar 'clayer) 90) (defun _SetLayerTransparency (LayerName Transparency / lyr) (and (<= 0 Transparency 90) (setq lyr (tblobjname "LAYER" LayerName)) (not (setpropertyvalue lyr "Transparency" Transparency)) (not (entupd lyr)) ) ) (defun _loadlinetype (ltype / lt out) (cond ((tblobjname "ltype" ltype) t) ((setq lt (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object)))) (setq out (vl-catch-all-apply 'vla-load (list lt ltype (findfile (if (= 0 (getvar 'measurement)) "acad.lin" "acadiso.lin" ) ) ) ) ) (not (vl-catch-all-error-p out)) ) ) ) ;; defun _loadlinetype ;; Set the layer properties (setq lay (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) name)) ;; 1st arg (if (listp color) (progn (setq tru (vla-get-truecolor lay)) (apply 'vla-setrgb (cons tru color)) (vla-put-truecolor lay tru) ) (vla-put-color lay color) ;; 2nd arg ) (vla-put-linetype lay (if (_loadlinetype linetype) linetype "continuous" ) ) ;; 3rd arg (vla-put-lineweight lay lineweight) ;; 4th arg (_SetLayerTransparency name transparency) ;; 5th arg (vla-put-Plottable lay plottable) ;; 6th arg (vla-put-description lay description) ;; 7th arg lay ) ;; end _createOrUpdateLayer defun ; (c:BKHatch__Solid_With_Wipeout)

I'd perhaps look at mapcar for the new insert point, something like this: (setq Insert-Point (mapcar '+ '(0 -0.32 0) Insert-Point)) What does it do? Does it create the text in the same location as before or not create the text at all?

And this adds it into the above: Note: Some text in the example drawing is surrounded by hatching, it might be better to colour all text black or a different shade of grey for visibility reasons. (defun c:test ( / NewColour NewLayer MySS acount MyEnt ed) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;Sub Functions (defun checklaystyle (LayDef / LayName Style ) ;;Check layer exists or create layer ;; 1-6 in def LISP, 7 is transparency: Check or create layer:- ;; "Layer", Name, flags, Colour, linetype, plotting, lineweight, Transparency (defun LM:setlayertransparency ( lay trn / ent ) ;;Ref Lee Mac (defun LM:trans->dxf ( x ) (logior (fix (* 2.55 (- 100 x))) 33554432) ) (if (setq ent (tblobjname "layer" lay)) (progn (regapp "accmtransparency") (entmod (append (entget ent) (list (list -3 (list "accmtransparency" (cons 1071 (LM:trans->dxf trn)) ) ; end list ) ; end list ))) ; end entmod ) ; end progn ) ; end if ) ; end defun (setq Layname (nth 1 LayDef)) (if ;;check if layer exists in drawing (or (= NIL (tblsearch "layer" Layname))(/= (cdr (assoc 2 (tblsearch "layer" Layname))) 0.0) ) (progn ;;If not entmake it (setq style (entmakex (list '(000 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 002 (nth 1 LayDef)) ; layer name (cons 070 (atoi (nth 2 LayDef))) ; (cons 062 (atoi (nth 3 LayDef))) ; colour (cons 006 (if (tblsearch "LTYPE" (nth 4 LayDef)) (nth 4 LayDef) "Continuous")) ; line type (cons 290 (atoi (nth 5 LayDef))) ; (if (or (= (nth 6 LayDef) nil)(= (nth 6 LayDef) "")) ; plotting (cons 370 -3) (cons 370 (atoi (nth 6 LayDef))) ) ))) ; end list, end entmake, end style (if (> (length layDef) 8) ;;Set layer transparency (LM:setlayertransparency Layname (atoi (nth 7 LayDef)) ) ) ) ;end progn ) ; end if ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ALLBB ( / MyBlock MyEnt MySS ed acount) ;;Set all entities in all blocks to ByBlock, layer 0 (setq MyBlock (tblnext "Block" T)) ;; Get first block definition (while MyBlock ;; Loop through block definitions (setq MyEnt (cdr (assoc -2 MyBlock))) ;; Get first entity in block (while MyEnt ;; Loop through block entities (setq ed (entget MyEnt)) (setq ed (append ed '((62 . 0)))) ;; Add ByBlock colour if it doesn't have colour set (setq ed (subst (cons 62 0) (assoc 420 ed) ed )) ;; Remove true colour (setq ed (subst (cons 62 0) (assoc 62 ed) ed )) ;; Modify Colour index (setq ed (subst (cons 8 "0") (assoc 8 ed) ed )) ;; Layer (if (= (cdr (assoc 0 ed)) "MTEXT") (setq ed (MTextCol ed))) (entmod ed) (setq MyEnt (entnext MyEnt)) ;; next entity in block ) ; end while (setq MyBlock (tblnext "Block")) ;; Next block ) ; end while (command "regen") ;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/is-there-a-lisp-to-run-battman-or-attsync-for-all-blocks-in-a/td-p/10847443 (if (ssget "_X" '((0 . "INSERT")(66 . 1))) (command "_.attsync" "Name" "*") ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun MTextCol ( ed / MyString StrPos ColonPos ColourCode) ;;Re-sets mtext override colours (setq MyString (cdr (assoc 1 ed))) (if (or (wcmatch (strcase MyString) "*`\C*;*") (wcmatch (strcase MyString) "*`\\C*;*") ) ; endor (progn (while (wcmatch (strcase MyString) "*`\\C*;*") (setq StrPos (vl-string-search "\\C" (strcase MyString) ) ) (setq ColonPos (+ (vl-string-search ";" MyString (+ StrPos 3)) 2)) (setq ColourCode (substr MyString (+ StrPos 1) (- ColonPos (+ StrPos 1)) ) ) (setq MyString (vl-string-subst "" ColourCode MyString) ) ) ; end while (setq ed (subst (cons 1 MyString) (assoc 1 ed) ed )) ;; text String <~250 characters ) ; end progn ) ; end if ed ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun c:purgea( / endloop sel) ;; Purge all (setq NoMutt_Old (getvar 'NoMutt)) (setvar 'NoMutt 1) (command "-PURGE" "A" "*" "N") ;; 'All' (setvar 'NoMutt NoMutt_Old) ) ;; End sub functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (setq NewColour 252) ;; Colour (setq NewLayer "XR") ;; Layer (c:purgea) ;; Initial Purge all (checklaystyle (list "LAYER" NewLayer "0" "0" "Continuous" "1" "-3" "0.0000") ) ;; To Check new layer exists (ALLBB) ;; Set all block entities to layer 0, colour 0 (if (setq MySS (ssget "X")) ;; select all (progn (setq acount 0) (while (< acount (sslength MySS)) ;; Loop through selection (setq MyEnt (ssname MySS acount)) ;; Get each entity defition (setq ed (entget MyEnt)) (if (= (assoc 62 ed) nil) ;; Colour index (setq ed (append ed '((62 . 1)))) ) ; end if (setq ed (subst (cons 62 NewColour) (assoc 420 ed) ed )) ;; Remove true colour (setq ed (subst (cons 62 NewColour) (assoc 62 ed) ed )) ;; Modify Colour index (setq ed (subst (cons 8 NewLayer) (assoc 8 ed) ed )) ;; Layer (if (= (cdr (assoc 0 ed)) "MTEXT") (setq ed (MTextCol ed))) (entmod ed) ;; Modify & update entity (setq acount (+ acount 1)) ) ; end while (setvar 'clayer "0") ;; Active layer '0' )) ; end if end progn (c:purgea) ;; Purge all (c:purgea) ;; Purge all, 2x to be sure (princ) )

@Mr Bojangles Here is a better example that includes a dialog box to select the file. You can change the command name and strings as stated in the comments to suit you needs. NOTE: in the path string, backslashes between folders have to be doubled "\\". Are these G-code files? I put the extension "gco" on the file dialog, but yours might use "g", "nc" or something else? ;; Change the command name to suit ;; Change the "C:\\Myfolder" path to whatever your files are located. ;; Change the "gco" (G code) file extension to whatever you are using (defun c:STRIPGC () (if (setq fil (getfiled "Select File to Strip" "C:\\Myfolder\\" "gco" 4)) (StripTextAtKwords fil "; Main Program Start" "; End Topcut") ) ) ;; Strips an ASCI text file of any lines between to keyword lines. (defun StripTextAtKwords (file kw1 kw2 / flg fp ln ls n) (if (and file (setq file (findfile file))) (progn (setq fp (open file "r") flg nil) (while (setq ln (read-line fp)) (if (= ln kw1)(setq flg T ls (cons ln ls))) (if (= ln kw2)(setq flg nil)) (if (not flg)(setq ls (cons ln ls))) ) (close fp) (if ls (progn (setq fp (open file "w") ls (reverse ls) n 0 ) (repeat (length ls) (write-line (nth n ls) fp) (setq n (1+ n)) ) (close fp) (princ "\nFile Updated.") ) ) ) (princ "\nFile Not found.") ) (princ) )

@Mr Bojangles It seems to work fine for me if the correct keywords are supplied. As long as the strings for kw1 and kw2 match the whole line: (defun c:test () (StripTextAtKwords "keywords.txt" "; Main Program Start" "; End Topcut") ) Results: #XZERO! = SD.USR.Allign.XPosActWPZP 1 #YZERO! = SD.USR.Allign.YPosActWPZP 1 IF (SD.ROTO.Batch=FALSE) THEN G1 G53 G153 G90 S90000 F30000 M3 G8 G17 G40 G47 G71 FFW(1) JKC(1) CLN(1) CLN(CollErr0) CLN(DLA4) M991 G1 Z50. F30000 ED1 1 ENDIF LP 8329025(0, 0, 0, 0) 1 IF (SD.ROTO.Batch=FALSE) THEN MIR(0) ROT(0) G153 G1 Z50 F30000 X[#XPLATE!] Y[#YPLATE!] M992 N10 ;***** END OF PROGRAM ***** 1 ENDIF M30 LPS 8329025 ; P1 X Offset ; P2 Y Offset ; P3 Rotation Angle ; P4 Operation to run in batch mode or all if 0 1 XOFFSET!=P1! : YOFFSET!=P2! : ROTANG!=P3! : OPERATION%=P4% 1 IF (SD.ROTO.Batch=TRUE) AND (OPERATION%=0) THEN 1 OPERATION%=SD.ROTO.BatchOperation 1 XOFFSET!=SD.ROTO.BatchXOffset 1 YOFFSET!=SD.ROTO.BatchYOffset 1 ROTANG!=SD.ROTO.BatchRotationOffset 1 ENDIF ; Plate TPH After Finishing 1 #DIEHEIGHT!=0.458 ; Programmed Z-Depth 1 #ZDEPTH!=-0.233 1 #ZZERO! = #DIEHEIGHT!+SD.ROTO.TableHeightAdjust 1 #XPLATE! = #XZERO!-XOFFSET!*COS(SD.USR.Allign.ResAngle)-YOFFSET!*SIN(SD.USR.Allign.ResAngle) 1 #YPLATE! = #YZERO!+YOFFSET!*COS(SD.USR.Allign.ResAngle)-XOFFSET!*SIN(SD.USR.Allign.ResAngle) 1 #RPLATE! = ROTANG!+SD.USR.Allign.ResAngle 1 PMT("PSI",154,1)=0 ; Main Program Start ; End Topcut 1 ENDIF 1 IF (OPERATION%=2) OR (OPERATION%=0) THEN ; Finishing 1 #FEEDRATE = 1417 LP TlChange LP Qualify(1.000,0.0,0.0) ; Qualify Sharp LP STP9025(521, 1, 90) LP TlChange LP Qualify(1.000,0.0,0.0) ; Qualify Sharp LP STP9025(521, 91, 180) ; End Finishing 1 ENDIF PEND ; End Subrouti

When storing doubles as strings, I like to use a function such as this - ;; Number to String - Lee Mac ;; Converts a supplied numerical argument to a string (defun LM:num->str ( num / dim rtn ) (if (equal num (atoi (rtos num 2 0)) 1e-8) (rtos num 2 0) (progn (setq dim (getvar 'dimzin)) (setvar 'dimzin 8) (setq rtn (rtos num 2 15)) (setvar 'dimzin dim) rtn ) ) ) This ensures that the supplied number is stored to the maximum precision afforded by the double precision floating point format, but in the shortest string necessary to represent the number to the maximum available precision (e.g. integers are stored as integers, doubles have all trailing zeroes removed).

Pretty much the same as Al above, but iterating over blocks: (defun c:sol2sand ( / doc ) (vlax-for blk (vla-get-blocks (setq doc (vla-get-activedocument (vlax-get-acad-object)))) (if (= :vlax-false (vla-get-isxref blk)) (vlax-for obj blk (if (and (= "AcDbHatch" (vla-get-objectname obj)) (= "SOLID" (strcase (vla-get-patternname obj))) (vlax-write-enabled-p obj) ) (progn (vla-setpattern obj achatchpatterntypepredefined "AR-SAND") (vla-put-patternscale obj 1000.0) ) ) ) ) ) (vla-regen doc acallviewports) (princ) ) (vl-load-com) (princ)