Copy blocks to curve according to another curve

[HypnoS]

Hi all,

I was wondering if someone could help me with a lisp modyfication. 

I need to modify CopyBlockStoCurve lisp so I don't need to select each block individually co copy it to the curve. I thought why not copy a function from numpol, which numbers blocks according to a polyline. So I need the new CopyBlockStoCurve to arrange blocks on a curve, but in accordance with how the blocks are positioned on another polyline basiclly.

Can anyone help?

 

 

 

numpol.lspCopyBlocksToCurve.lsp

[SLW210]

Can you post a before and after drawing?

[HypnoS]

[SLW210]

That's not a drawing, just images.

 

I don't see a curve.

 

Is the text part of the block?

 

Really need the drawing.

[HypnoS]

okay so these are dynamic blocks with attributes, thats why i use numpol to change attribute values acording to polyline i drew over them.

Now I want to use something like copyblockstocurve (wich works also with polylines) to align my blocks to new straight line in the same order numpol did the numering. So that I could use them to draw a scheme.

Example.dwg

[devitg]

@HypnoS Please give it a try 

cpy-blk-2-poly.lsp

[BIGAL]

Another give it a try.

; https://www.cadtutor.net/forum/topic/98615-copy-blocks-to-curve-according-to-another-curve/
; get blocks along a pline at any XY then redo as a straight line.
; By AlanH July 2025

(defun c:wow ( / bname co-ord ent obj plent pt spac ss x)

(setq oldsnap (getvar 'osmode))
(setvar 'osmode 0)

(setq plent (car (entsel "\pick pline joining blocks ")))
(setq obj (vlax-ename->vla-object (car (entsel "\nPick block object "))))
(setq pt (getpoint "\nPick left point "))
(setq spac (getreal "\Enter spacing "))
(setq bname (vlax-get obj 'effectivename))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget plent))))

(setq ss (ssget "F" co-ord '((0 . "INSERT"))))

(command "line" pt (mapcar '+ pt (list (* (- (sslength ss) 1) spac) 0.0 0.0)) "")

(repeat (setq x (sslength ss))
 (setq ent (ssname ss (setq x (- x 1))))
 (setq obj (vlax-ename->vla-object ent))
 (if (= (vlax-get obj 'effectivename) bname)
 (progn
   (command "copy" ent "" (vlax-get obj 'Insertionpoint) pt)
   (setq pt (mapcar '+ pt (list spac 0.0 0.0)))
 )
 )
)

(princ)
)

 

[HypnoS]

@devitg Yours seams to not work for me at all 

 

@BIGAL I can't quite go through this routine to see final result. nothing happens after i daw a line. Also I already have a polyline that goes though all blocks that I need,  so the part in lisp that tells me to draw line over blocks is unnecessary

 

To be more precise. Lisp CopyBlockstocurve works great, the only part i want to change is that I dont want to click on each block to copy it to straight line. I want them to be copied automaticlly acording to pline that is existing

[devitg]

@HypnoS Please show the command line text or error message. 

 

 

[SLW210]

Here is my effort, worked on your drawing for me.

 

;;; Copy blocks to a polyline/line path in ascending order left to right based on ATTRIBUTE TAG value.             |
;;;                                                                                                                |
;;; https://www.cadtutor.net/forum/topic/98615-copy-blocks-to-curve-according-to-another-curve/#findComment-675378 |
;;;                                                                                                                |
;;; By SLW210 (a.k.a. Steve Wilson)                                                                                |
;;;                                                                                                                |
;;;****************************************************************************************************************|

;| Lines/Polylines need be drawn Left-Right or reversed, could be coded to check direction and reverse them.       
   I'm not motivated to do that, but feel free to alter the code.                                                  
   I did test on angled Polylines/Lines as well as vertical and it works, but might need adjustments.              
   I adjusted a code I already had to handle this specific request for which it works, I doubt if I'll             
   do anymore modifications.                                                                                      |;

;;;***************************************************************************************************************|
;;; This code asks to select the block and type in the tag name from options given (case sensitive).              |
;;;                                                                                                               |
;;;***************************************************************************************************************|

(defun c:BlksSrt2PL (/		blkLst	   spacing    pathEnt
		     pathObj	blkCopy	   len	      i
		     param	pt	   getAtVal  parsFract
		     attrVal	blk	   startPt    endPt
		     dx		dy	   visStart   dist
		     tangent	rotAngle   pathDist   objType
		     blkSelEnt	blkSelObj  tagList    tagNames
		     selTag
		    )

  (vl-load-com)

  ;; Function to get attribute value by tag name
  (defun getAtVal (blk tag / atts val)
    (setq atts (vlax-invoke blk 'GetAttributes))
    (setq val "")
    (foreach att atts
      (if (= (strcase (vla-get-TagString att)) (strcase tag))
	(setq val (vla-get-TextString att))
      )
    )
    val
  )

  ;; Function to convert fractional strings (like "1/2") to numbers
  (defun parsFract (s / pos num1 num2)
    (cond
      ((setq pos (vl-string-search "/" s))
       (setq num1 (read (substr s 1 pos)))
       (setq num2 (read (substr s (+ pos 2))))
       (if (and num1 num2 (/= num2 0))
	 (/ (float num1) num2)
	 0.0
       )
      )
      ((distof s))
      (T 0.0)
    )
  )

  ;; Select a block to determine attribute tag name
  (prompt "\nSelect a block to determine the tag name:")
  (setq blkSelEnt (car (entsel "\nSelect a block with attributes: ")))
  (if (not blkSelEnt)
    (progn
      (prompt "\nNo block selected. Exiting.")
      (exit)
    )
  )

  (setq blkSelObj (vlax-ename->vla-object blkSelEnt))

  (if (not (vla-get-HasAttributes blkSelObj))
    (progn
      (prompt "\nSelected block has no attributes. Exiting.")
      (exit)
    )
  )

  ;; Get all attribute tags from selected block
  (setq tagList '())
  (foreach att (vlax-invoke blkSelObj 'GetAttributes)
    (setq tagList (cons (vla-get-TagString att) tagList))
  )

  (setq
    tagNames (apply 'strcat
		    (mapcar '(lambda (x) (strcat "\n - " x)) tagList)
	     )
  )
  (prompt
    (strcat "\nAvailable tags in selected block:" tagNames)
  )
  (initget 1)
  (setq selTag (getstring "\nEnter the tag to use: "))

  ;; --- Collect all blocks with that attribute tag ---
  (setq blkLst '())
  (vlax-for ent	(vla-get-ModelSpace
		  (vla-get-ActiveDocument (vlax-get-Acad-Object))
		)
    (if	(and (= (vla-get-ObjectName ent) "AcDbBlockReference")
	     (vla-get-HasAttributes ent)
	)
      (progn
	(setq attrVal (getAtVal ent selTag))
	(if (and attrVal (/= attrVal ""))
	  (setq blkLst (cons (list (parsFract attrVal) ent) blkLst))
	)
      )
    )
  )

  (if (= (length blkLst) 0)
    (progn
      (prompt "\nNo matching blocks found.")
      (exit)
    )
  )

  ;; Select path: polyline or line
  (prompt "\nSelect path (polyline or line): ")
  (setq pathEnt (car (entsel "\nSelect path (polyline or line): ")))
  (if (not pathEnt)
    (progn
      (prompt "\nNo object selected. Exiting.")
      (exit)
    )
  )

  (setq pathObj (vlax-ename->vla-object pathEnt))
  (setq objType (vla-get-ObjectName pathObj))

  (if (or (equal objType "AcDbPolyline")
	  (equal objType "AcDbLine")
      )
    (progn
      (setq startPt (vlax-curve-getStartPoint pathObj))
      (setq endPt (vlax-curve-getEndPoint pathObj))
    )
    (progn
      (prompt
	(strcat	"\nSelected object is not a polyline or line: "
		objType
		". Exiting."
	)
      )
      (exit)
    )
  )

  ;; Determine start point
  (setq dx (- (car endPt) (car startPt)))
  (setq dy (- (cadr endPt) (cadr startPt)))

  (if (> (abs dy) (abs dx))
    ;; Mostly vertical
    (setq visStart (if (> (cadr startPt) (cadr endPt))
		     startPt
		     endPt
		   )
    )
    ;; Mostly horizontal or diagonal
    (setq visStart (if (< (car startPt) (car endPt))
		     startPt
		     endPt
		   )
    )
  )

  ;; Sort blocks by numeric tag value
  (setq	blkLst (vl-sort	blkLst
			(function (lambda (a b) (> (car a) (car b))))
	       )
  )
  (if (not (equal startPt visStart 1e-6))
    (setq blkLst (reverse blkLst))
  )

  ;; Ask for spacing
  (initget 7)
  (setq spacing (getdist "\nEnter spacing between blocks: "))

  ;; Place and rotate blocks along path
  (setq len (length blkLst))
  (setq i 0)
  (setq dist 0.0)
  (setq	pathDist (vlax-curve-getDistAtParam
		   pathObj
		   (vlax-curve-getEndParam pathObj)
		 )
  )

  (while (and (< i len) (< dist pathDist))
    (setq pt (vlax-curve-getPointAtDist pathObj dist))
    (setq tangent (vlax-curve-getFirstDeriv
		    pathObj
		    (vlax-curve-getParamAtDist pathObj dist)
		  )
    )
    (setq rotAngle (atan (cadr tangent) (car tangent)))

    ;; Flip angles to keep blocks upright
    (if	(or (> rotAngle (/ pi 2)) (< rotAngle (- (/ pi 2))))
      (setq rotAngle (+ rotAngle pi))
    )

    (if	pt
      (progn
	(setq blk (cadr (nth i blkLst)))
	(setq blkCopy (vla-copy blk))
	(vla-put-InsertionPoint blkCopy (vlax-3d-point pt))
	(vla-put-Rotation blkCopy rotAngle)
      )
    )

    (setq dist (+ dist spacing))
    (setq i (1+ i))
  )

  (prompt (strcat "\nCopied " (itoa i) " blocks along path."))
  (princ)
)

 

[SLW210]

3 hours ago, devitg said:

@HypnoS Please show the command line text or error message. 

 

 

I get 

 

Command: CPY-BLK-2-POLY

Select objects:
; error: bad argument type: lselsetp nil
 

[devitg]

48 minutes ago, SLW210 said:

I get 

 

Command: CPY-BLK-2-POLY

Select objects:
; error: bad argument type: lselsetp nil
 

@SLW210 please upload sample dwg , where yo did apply the lisp

 

[devitg]

@SLW210 @HypnoS edited please test. 

 

 

cpy-blk-2-poly.lsp

[SLW210]

On 7/22/2025 at 6:46 AM, HypnoS said:

okay so these are dynamic blocks with attributes, thats why i use numpol to change attribute values acording to polyline i drew over them.

Now I want to use something like copyblockstocurve (wich works also with polylines) to align my blocks to new straight line in the same order numpol did the numering. So that I could use them to draw a scheme.

Example.dwg 40.24 kB · 6 downloads

 

I used the one supplied by the OP.

[SLW210]

Your latest works in AutoCAD 2000i on my home computer, though it makes a new line was that intended?

 

I like yours a lot.

[devitg]

15 minutes ago, SLW210 said:

Your latest works in AutoCAD 2000i on my home computer, though it makes a new line was that intended?

 

I like yours a lot.

@SLW210 it ask for the polyline where the blocks are inserted, then get the coordinates from such polyline , and use it to get all blocks as  selectionset . 

It draw a polyline straight long enough to receive the new block at a given distance, 1000 units in this cas

 

Then it copy each one and move to the new line