Create array within a boundary

[jpcadconsulting347236]

Hi folks,

I'm looking for a routine similar to superhatch that will:

1. Let me select a block (by name or by selecting it on screen)
2. Enter spacing for rows/columns
3. Select a boundary (polyline, circle, spline, etc.) either by internal point or "select object"
4. Fill that area with instances of that block at the desired spacing.

Superhatch was my first thought, and it's close... but when you explode the hatch, you get lines and arcs and I need the individual blocks to remain intact so I can extract data from them.

There are a few others out there (Supercopy, etc.) but none work quite properly for what I need.

Advanced Array comes close but its has it's own issues (mostly because it was written in 2007):

http://cadtips.cadalyst.com/content/filling

1. There are times when the setting of values regarding display of hatches (or your row spacing) can cause this routine to fail because it can (I assume) come up against the "Hatch too dense to display" error.
2. You cannot "select object(s)" to select the boundary, only "select internal point" which in large drawings can have issues.
3. It's "finicky" about how you enter the row and column distances (sometimes it just doesn't "take")
4. There is no undo "mark" (if that's what you call it) so if you need to undo, it steps through each block, one at a time, then the hatch elements... etc.

Anyone know of anything? I'm coming up empty.

Thanks in advance for your help. Following is the LSP and DCL for Advanced Array which should do exactly what I need but does not work well in 2014.

LSP

;;;Cadalyst AutoLISP Solutions	July 2007	ALSPSOL0707.ZIP / ADARRAY.LSP 	(c) Tony Hotchkiss
;;; 
(defun err (s)
  (if (= s "Function cancelled")
    (princ "\nADARRAY - cancelled: ")
    (progn (princ "\nADARRAY - Error: ")
	   (princ s)
	   (terpri)
    ) ;_ progn
  ) ;_ end of if
  (resetting)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
) ;_ end of err
(defun setv (systvar newval)
  (setq x (read (strcat systvar "1")))
  (set x (getvar systvar))
  (setvar systvar newval)
) ;_ end of setv
(defun setting ()
  (setq oerr *error*)
  (setq *error* err)
  (setv "CMDECHO" 0)
  (setv "BLIPMODE" 0)
  (setv "OSMODE" 0)
  (setv "CLAYER" (getvar "CLAYER"))
) ;_ end of setting
(defun rsetv (systvar)
  (setq x (read (strcat systvar "1")))
  (setvar systvar (eval x))
) ;_ end of rsetv
(defun resetting ()
  (rsetv "CMDECHO")
  (rsetv "BLIPMODE")
  (rsetv "OSMODE")
  (rsetv "CLAYER")
  (setq *error* oerr)
) ;_ end of resetting

(defun adarray ()
  (vl-load-com)
  (setq	*thisdrawing* (vla-get-activedocument
			(vlax-get-acad-object)
		      ) ;_ end of vla-get-activedocument
	*modelspace*  (vla-get-ModelSpace *thisdrawing*)
  ) ;_ end of setq
  (setq	bnameindex nil)
  (setq doit 4)
  (setq ad_id (load_dialog "adarray.dcl"))
  (while (>= doit 2)
    (if	(not (new_dialog "adarray" ad_id))
      (exit)
    ) ;_ end of if
    (init-array)
    (action_tile "bname" "(setq bnameindex (atoi $value))")
    (action_tile "row" "(setq *rowdist* (atof $value))")
    (action_tile "col" "(setq *coldist* (atof $value))")
    (action_tile "pick" "(done_dialog 3)")
    (action_tile
      "accept"
      "(get-adarray-data) (done_dialog 1)"
    ) ;_ end of action_tile
    (setq doit (start_dialog))
    (cond
      ((= doit 1)
       (do-array)
      )
      ((= doit 3)
       (setq *point0* (getpoint "\nPick a point: "))
      )
    ) ;_ end of cond
  ) ;_ end of while
  (unload_dialog ad_id)
) ;_ end-of adarray

(defun init-array ()
  (setq	blks (vla-get-blocks *thisdrawing*)
	num  (vla-get-Count blks)
	*blknames* nil
	i 1
  ) ;_ end of setq
  (repeat (- num 2)
    (setq blk	   (vla-item blks (setq i (1+ i)))
	  bname	   (vla-get-Name blk)
	  *blknames* (append *blknames* (list bname))
    ) ;_ end of setq
  ) ;_ end of repeat
  (if *blknames*
    (progn
      (start_list "bname")
      (mapcar 'add_list *blknames*)
      (end_list)
    ) ;_ end of progn
  ) ;_ end of if
  (if bnameindex
    (set_tile "bname" (itoa bnameindex))
  ) ;_ end of if
  (if *rowdist*
    (set_tile "row" (rtos *rowdist*))
    (set_tile "row" "2")
  ) ;_ end of if
  (if *coldist*
    (set_tile "col" (rtos *coldist*))
    (set_tile "col" "2")
  ) ;_ end of if
) ;_ end of init-array

(defun get-adarray-data ()
  (setq bnameindex (atoi (get_tile "bname")))
  (setq *bname* (nth bnameindex *blknames*)) 
  (setq *rowdist* (atoi (get_tile "row")))
  (setq *coldist* (atoi (get_tile "col")))
) ;_ end-of get-tool-data

(defun do-array ()
  (setq lyr "arr-hatch")
  (vl-cmdf "Layer" "M" lyr "C" "green" "" "")
  (vl-cmdf "-Hatch" *point0* "P" "U" "0.0" *rowdist* "N" "")
  (vl-cmdf "Explode" (entlast))
  (setq	ss     (ssget "X"
		      (list '(0 . "LINE")
			    (cons 8 lyr)
		      ) ;_ end of list
	       ) ;_ end of ssget
	num    (sslength ss)
	i      -1
  ) ;_ end of setq
  (rsetv "CLAYER")
  (repeat num
    (setq en (ssname ss (setq i (1+ i))))
    (vl-cmdf "Measure" en "B" *bname* "Y" *coldist*)
    (entdel en)
  ) ;_ end of repeat
) ;_ end of do-array

(defun c:ad ()
  (setting)
  (adarray)
  (resetting)
  (princ)
) ;_ end of c:ad

(prompt "\nCopyright (c) 2007, Tony Hotchkiss")
(prompt "\nEnter AD to start")

DCL

// ADARRAY Dialogue Box - by Tony Hotchkiss 4/21/07
adarray : dialog // advanced array data
{
   label = "ADAVANCED ARRAY";
      :column {
        :popup_list {
          label = "Block name     ";
          key = "bname";
          width = 8;
        }// popup list
        :edit_box {
          label = "Distance between rows:      ";
          key = "row";
          width = 8;
        }// edit box
        :edit_box {
          label = "Distance between columns:";
          key = "col";
          width = 8;
        }// edit box
        :spacer {}
        :spacer {}
        : retirement_button {
           key = "pick";
           label = "Pick point";
        }// retirement_button
       }// column
   ok_cancel;
   : text {
      label = "Copyright (c) 2007 Dr. A. Hotchkiss";
      alignment = left;
   }
} // adarray

-JP

[BIG-AL]

There is a simple way to do it pick a lower left point upper right and a control point. Array your new infill block but make it larger than required in terms of number, then pick boundary as indicated and erase all outside of this boundary. I did this years ago for waffle slab panel design drawing squares on any shape from a known point just a couple of picks and all done trimmed back to the shape.

Anyway here is the auto trim the hard bit

(defun c:trpls ( / x pt2 obj obj2 co-ords)
(setq oldsnap (getvar "osmode"))
(setvar "osmode" 0)
(setq x -1) 
(setq obj (car (entsel "\nPick cut line")))

(setq pt2 (getpoint "pick offset direction"))
(command "_offset" 1 obj pt2 "")

(if (not co-ords2xy)(load "pline co-ords2"))
(setq obj2 (entlast))
(setq co-ords (getcoords obj2))
(co-ords2xy) ; list of 2d points making pline
(entdel obj2)

(command "_TRIM" OBJ "" "F")
(while (= (getvar "cmdactive") 1 ) 
(repeat (length co-ordsxy)
(command  (nth (setq x (+ x 1)) co-ordsxy))
)
(command "")
)

(setq co-ordsxy nil) ; for next time
)

; pline co-ords example
; By Alan H
(defun getcoords (ent)
  (vlax-safearray->list
    (vlax-variant-value
      (vlax-get-property
    (vlax-ename->vla-object ent)
    "Coordinates"
      )
    )
  )
)
 
(defun co-ords2xy ()
; convert now to a list of xy as co-ords are x y x y x y if 3d x y z x y z
(setq len (length co-ords))
(setq numb (/ len 2)) ; even and odd check required
(setq I 0)
(repeat numb
(setq xy (list (nth i co-ords)(nth (+ I 1) co-ords) ))
; odd (setq xy (list (nth i co-ords)(nth (+ I 1) co-ords)(nth (+ I 2) co-ords) ))
(setq co-ordsxy (cons xy co-ordsxy))
(setq I (+ I 2))
)
)

; program starts here
(setq co-ords (getcoords (car (entsel "\nplease pick pline"))))
;(co-ords2xy) ; list of 2d points making pline

[jpcadconsulting347236]

OK, I've done some testing and uncovered this.

If I change the bit of code in the LSP file that sets the values for Row distance, Column Distance and Block Name so that it is not pulling from the DCL values but instead is hard coded, it works great. So I assume its having trouble getting the values from the dialog box. My knowledge of DCL is even more lacking than my knowledge of LISP... Any help is appreciated.

I may try to cobble together a routine without using DCL if I can.

Original Code:

(defun get-adarray-data ()
  (setq bnameindex (atoi (get_tile "bname")))
  (setq *bname* (nth bnameindex *blknames*)) 
  (setq *rowdist* (atoi (get_tile "row")))
  (setq *coldist* (atoi (get_tile "col")))
) ;_ end-of get-tool-data

Modified Code:

(defun get-adarray-data ()
  (setq bnameindex (atoi (get_tile "bname")))
  (setq *bname* "Pro Perennial") 
  (setq *rowdist* 48)
  (setq *coldist* 48)
) ;_ end-of get-tool-data

[jpcadconsulting347236]

Allright...

I have cobbled (and I mean cobbled) this together and it almost works...

Prompts for Row and Column distances (enter value or pick points)
Prompts to select a block to use
Prompts for an internal point

It creates the array within the boundary as expected, but the blocks it inserts do not seem to have the attribute tag like the selected block does (see attached drawing).

As always, any help is appreciated.

(defun c:TESTadarray  (/ ent STR lyr ss rowdist coldist point0)

(setq rowdist (getdist "\n Distance Between rows :"))
(setq coldist (getdist "\n Distance Between columns :"))

     (cond
           ((and
                  (setq ent (car (entsel "\nSelect Block Entity: ")))
                  (eq (cdr (assoc 0 (entget ent))) "INSERT")
                  (setq STR (vla-get-effectivename
                                        (vlax-ename->vla-object ent)))
            )))

  (setq lyr "L-PL PERENNIAL")
  (vl-cmdf "Layer" "M" lyr "C" "yellow" "" "")
  (vl-cmdf "-Hatch" (getpoint "\nPick a point: ") "P" "U" "0.0" rowdist "N" "")
  (vl-cmdf "Explode" (entlast))
  (setq	ss     (ssget "X"
		      (list '(0 . "LINE")
			    (cons 8 lyr)
		      ) ;_ end of list
	       ) ;_ end of ssget
	num    (sslength ss)
	i      -1
  ) ;_ end of setq
  (repeat num
    (setq en (ssname ss (setq i (1+ i))))
    (vl-cmdf "Measure" en "B" STR "Y" coldist)
    (entdel en)
  ) ;_ end of repeat
)

[jpcadconsulting347236]

This seems to be an issue with the MEASURE command and blocks with attributes. Added the following line and seems to be working now. Still, I'm sure it could be cleaned up, error handling added, etc.

(vl-cmdf "attsync" "Name" STR)

[Simon W.]

Hi everyone,

I am pretty new to Lisp and also new to this Forum.
I am really excited about Lisp and really motivated to learn but the code above is beyond my knowledge.
The Routine sounds like it would be perfect to safe me a lot of time but unfortunately its not working till now.
When I pick the Block and I wand to pick a point I always get the error: bad Argument type: lselsetp Nil.

Can you give me a hint where to find the Problem?

Any help is appreciated!


Best
Simon

[BIG-AL]

Jpcad here is a lisp that has a 1 2 or 3 dcl input its a library style routine so you load as required.

; Input  Dialog box with variable title
; multiple lines of dcl input supported
; add extra lines if required by copying code defun
; By Alan H 2015
(vl-load-com)

; 1 line dcl
; sample code (ah:getval1 "Line 1" 5 4 "-")
(defun AH:getval1 (title width limit def1 / fo fname)
; you can hard code a directory if you like for dcl file
(setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w"))
;(setq fo (open (setq fname "c:\\acadtemp\\getval.dcl") "w"))
(write-line "ddgetval : dialog {" fo)
(write-line " : row {" fo)
(write-line ": edit_box {" fo)
(write-line (strcat "    key = "  (chr 34) "key1" (chr 34) ";") fo)
(write-line  (strcat " label = "  (chr 34) title (chr 34) ";"  )   fo)
; these can be replaced with shorter value etc
(write-line (strcat "     edit_width = " (rtos width 2 0) ";" ) fo)
(write-line (strcat "     edit_limit = " (rtos limit 2 0) ";" ) fo)
(write-line "   is_enabled = true;" fo)
(write-line "    }" fo)
(write-line "  }" fo)
(write-line "ok_only;}" fo)
(close fo)

(setq dcl_id (load_dialog  fname))
; pt is a list 2 numbs -1 -1 centre ('(20 20))
;(not (new_dialog "test" dch "" *screenpoint*)) 
(if (not (new_dialog "ddgetval" dcl_id))
(exit))
(set_tile "key1" (setq val1 def1))
(action_tile "key1" "(setq val1 $value)")
(mode_tile "key1" 3)
(start_dialog)
(done_dialog)
(unload_dialog dcl_id)
; returns the value of val1 as a string
(vl-file-delete fname)
) ; defungetval1

; 2 line dcl
; sample code (ah:getval2 "Line 1" 5 4 "1" "Line2" 8 7 "2")
(defun AH:getval2 (title1 width1 limit1 def1 title2 width2 limit2 def2 / fo fname)
(setq fo (open (setq fname "c:\\acadtemp\\getval.dcl") "w"))
(write-line "ddgetval2 : dialog {" fo)
(write-line " : column {" fo)
(write-line ": edit_box {" fo)
(write-line (strcat "    key = " (chr 34) "key1" (chr 34) ";") fo)
(write-line  (strcat " label = "  (chr 34) title1 (chr 34) ";" ) fo)
(write-line (strcat "     edit_width = " (rtos width1 2 0) ";" ) fo)
(write-line (strcat "     edit_limit = " (rtos limit1 2 0) ";" ) fo)
(write-line "   is_enabled = true ;" fo)
(write-line "    }" fo)
(write-line "spacer_1 ;" fo)
(write-line ": edit_box {" fo)
(write-line (strcat "    key = " (chr 34) "key2" (chr 34) ";") fo)
(write-line (strcat " label = "  (chr 34) title2 (chr 34) ";"  ) fo)
(write-line (strcat "     edit_width = " (rtos width2 2 0) ";" ) fo)
(write-line (strcat "     edit_limit = " (rtos limit2 2 0) ";" ) fo)
(write-line "   is_enabled = true ;" fo)
(write-line "    }" fo)
(write-line "    }" fo)
(write-line "spacer_1 ;" fo)
(write-line "ok_only;}" fo)
(close fo)

; code part
(setq dcl_id (load_dialog  fname))
(if (not (new_dialog "ddgetval2" dcl_id))
(exit))
(mode_tile "key1" 3)
(set_tile "key1" (setq val1 def1))
(action_tile "key1" "(setq val1 $value)")
(mode_tile "key2" 3)
(set_tile "key2" (setq val2 def2))
(action_tile "key2" "(setq val2 $value)")
(start_dialog)
(done_dialog)
(unload_dialog dcl_id)
; returns the value of val1 and val2 as strings
(vl-file-delete fname)
) ; defungetval2

; 3 line dcl
; sample code (ah:getval3 "Line 1" 5 4 "0.9" "Line 2" 8 7 "wow" "Line 3" 6 4 "123")

(defun AH:getval3 (title1 width1 limit1 def1 title2 width2 limit2 def2 title3 width3 limit3 def3 / fo fname)
(setq fo (open (setq fname "c:\\acadtemp\\getval.dcl") "w"))
(write-line "ddgetval3 : dialog {" fo)
(write-line " : column {" fo)
(write-line ": edit_box {" fo)
(write-line (strcat "    key = " (chr 34) "key1" (chr 34) ";") fo)
(write-line  (strcat " label = "  (chr 34) title1 (chr 34) ";" ) fo)
(write-line (strcat "     edit_width = " (rtos width1 2 0) ";" ) fo)
(write-line (strcat "     edit_limit = " (rtos limit1 2 0) ";" ) fo)
(write-line "   is_enabled = true ;" fo)
(write-line "    }" fo)
(write-line "spacer_1 ;" fo)
(write-line ": edit_box {" fo)
(write-line (strcat "    key = " (chr 34) "key2" (chr 34) ";") fo)
(write-line (strcat " label = "  (chr 34) title2 (chr 34) ";"  ) fo)
(write-line (strcat "     edit_width = " (rtos width2 2 0) ";" ) fo)
(write-line (strcat "     edit_limit = " (rtos limit2 2 0) ";" ) fo)
(write-line "   is_enabled = true ;" fo)
(write-line "    }" fo)
(write-line "spacer_1 ;" fo)
(write-line ": edit_box {" fo)
(write-line (strcat "    key = " (chr 34) "key3" (chr 34) ";") fo)
(write-line (strcat " label = "  (chr 34) title3 (chr 34) ";"  ) fo)
(write-line (strcat "     edit_width = " (rtos width3 2 0) ";" ) fo)
(write-line (strcat "     edit_limit = " (rtos limit3 2 0) ";" ) fo)
(write-line "   is_enabled = true ;" fo)
(write-line "    }" fo)
(write-line "    }" fo)
(write-line "spacer_1 ;" fo)
(write-line "ok_only;}" fo)
(close fo)

; code part
(setq dcl_id (load_dialog  fname))
(if (not (new_dialog "ddgetval3" dcl_id))
(exit))
(mode_tile "key1" 3)
(set_tile "key1" (setq val1 def1))
(action_tile "key1" "(setq val1 $value)")
(mode_tile "key2" 3)
(set_tile "key2" (setq val2 def2))
(action_tile "key2" "(setq val2 $value)")
(mode_tile "key3" 3)
(set_tile "key3" (setq val3 def3))
(action_tile "key3" "(setq val3 $value)")
(start_dialog)
(done_dialog)
(unload_dialog dcl_id)
; returns the value of val1 val2 and val3 as strings
(vl-file-delete fname)
) ; defungetval3

(if (not ah:getval3)(load "getvals3"))
(ah:getval3 "Enter horiz scale" 5 4 "100" "Enter vertical scale " 5 4 "50" "Decimals" 5 4 "2")
(setq horiz (atof val1))
(setq vert (atof val2))  
(setq prec (atof val3))

[baskar.mg790662]

Hi., please help me when using TESTADARRAY.LSP as below.

Command: TESTADARRAY

Distance Between rows :1000

Distance Between columns :1000

Select Block Entity: Layer
Current layer: "L-PL PERENNIAL"
Enter an option [?/Make/Set/New/Rename/ON/OFF/Color/Ltype/LWeight/TRansparency/MATerial/Plot/Freeze/Thaw/LOck/Unlock/stAte/Description/rEconcile]: M
Enter name for new layer (becomes the current layer) <L-PL PERENNIAL>: L-PL PERENNIAL Enter an option [?/Make/Set/New/Rename/ON/OFF/Color/Ltype/LWeight/TRansparency/MATerial/Plot/Freeze/Thaw/LOck/Unlock/stAte/Description/rEconcile]: C
New color [Truecolor/COlorbook] : yellow
Enter name list of layer(s) for color 2 (yellow) <L-PL PERENNIAL>: Enter an option [?/Make/Set/New/Rename/ON/OFF/Color/Ltype/LWeight/TRansparency/MATerial/Plot/Freeze/Thaw/LOck/Unlock/stAte/Description/rEconcile]:
Command:
Pick a point: -Hatch
Current hatch pattern: _USER
Specify internal point or [Properties/Select objects/draW boundary/remove Boundaries/Advanced/DRaw order/Origin/ANnotative/hatch COlor/LAyer/Transparency]: Selecting everything...
Selecting everything visible...
Analyzing the selected data...

Analyzing internal islands...

Current hatch pattern: _USER
Specify internal point or [Properties/Select objects/draW boundary/remove Boundaries/Advanced/DRaw order/Origin/ANnotative/hatch COlor/LAyer/Transparency]: P
Enter a pattern name or [?/Solid/User defined/Gradient] <User defined>: U
Specify angle for crosshatch lines <0>: 0.0
Specify spacing between the lines <1000.0000>: 1000
Double hatch area? [Yes/No] <N>: N
Current hatch pattern: _USER
Specify internal point or [Properties/Select objects/draW boundary/remove Boundaries/Advanced/DRaw order/Origin/ANnotative/hatch COlor/LAyer/Transparency]:
Command: Explode
Select object:
Hatch boundary associativity removed.
Command: ; error: bad argument type: lselsetp nil

[BIG-AL]

There is no code to look at, run the code in VLIDE, make sure under Debug have break on error turned on, then run when error occurs click last break source, this will hopefully highlite the line that is causing the error