Speed up Lisp on block insert

May 12, 2020

Hey guys,

Im looking for a way to speed up the below lisp. For the files i'm running this on theirs over 10,000 points so it takes quiet a bit of time to run. I've noticed that the vast majority of the runtime is taken up by this section of code:

(while (/= PointsList nil)

(command "_.-INSERT" "L:/Work/SUR/LIBRARY/AutoCAD Civil 3D/General Settings/LISP/Point Management/Pointblock.dwg" (car PointsList) "" "" "" "STN")

(setq PointsList (cdr PointsList))
);end while

Is there a better way to insert a block that takes less processing time. I was going to try entmake but i don't know how to insert the "STN" text attribute that way.

If it helps the Tag that the "STN" text goes into is called "STNNO".

(vl-load-com)

(defun c:CREATEPOINTS ( / *error* file i en pe pm pb)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
      (princ (strcat "\nError: " errmsg)))
    (if file (close file))
    (princ))

(setq PointsList (list "0.000,0.000,0.000"))
(setvar 'ATTREQ 1) ;;;;system variable required for inserting attrobuted blocks
(setvar 'ATTDIA 0) ;;;;system variable required for inserting attrobuted blocks

  (if (setq ss (ssget '((0 . "LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
            pb (vlax-curve-getStartPoint en) ;;;;;gets start point of line or arc
            pe (vlax-curve-getEndPoint en)  ;;;;;gets end point of line or arc
            pm (if (= "ARC" (cdr (assoc 0 (entget en)))) ;;;;;Center point of arc
                 (cdr (assoc 10 (entget en)))
                 '(0 0 0)))

(setq Point2Process (List "pb" "pm" "pe"))
(while (/= Point2Process nil)

(setq PointX (rtos (car (eval (read (car Point2Process)))) 2 3))
(setq PointY (rtos (cadr (eval (read (car Point2Process)))) 2 3))
(setq PointZ (rtos (last (eval (read (car Point2Process)))) 2 3))

(setq PointsList (cons (strcat PointX "," PointY "," PointZ) PointsList))

(setq Point2Process (cdr point2process))
);end while 

);end repeat
);end if

(setq PointsList (bubblesort PointsList))
(setq PointsList (vl-remove "0.000,0.000,0.000" PointsList))

(command "_layer" "m" "CONTROL MARK" "")

(while (/= PointsList nil)

(command "_.-INSERT" "L:/Work/SUR/LIBRARY/AutoCAD Civil 3D/General Settings/LISP/Point Management/Pointblock.dwg" (car PointsList) "" "" "" "STN")

(setq PointsList (cdr PointsList))
);end while 

);end defun

May 12, 2020

With your currect code, you keep inserting an 'external' block.

The process will speed up when you insert and existing block.

So check if the block exists in the DWG, if not, load from external location.

If it does exist, directly insert it.

use the tblsearch function.

May 12, 2020

upload an example of the block in AutoCAD 2010 format. I have many routines that do this, or could be modified slightly for your block.

May 12, 2020

Sambo, what is (bubblesort pointlist) sub function?

May 12, 2020

4 hours ago, Sambo said:

Hey guys,

Im looking for a way to speed up the below lisp. For the files i'm running this on theirs over 10,000 points so it takes quiet a bit of time to run. I've noticed that the vast majority of the runtime is taken up by this section of code:


(while (/= PointsList nil)

(command "_.-INSERT" "L:/Work/SUR/LIBRARY/AutoCAD Civil 3D/General Settings/LISP/Point Management/Pointblock.dwg" (car PointsList) "" "" "" "STN")

(setq PointsList (cdr PointsList))
);end while

Is there a better way to insert a block that takes less processing time. I was going to try entmake but i don't know how to insert the "STN" text attribute that way.

If it helps the Tag that the "STN" text goes into is called "STNNO".


(vl-load-com)

(defun c:CREATEPOINTS ( / *error* file i en pe pm pb)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
      (princ (strcat "\nError: " errmsg)))
    (if file (close file))
    (princ))

(setq PointsList (list "0.000,0.000,0.000"))
(setvar 'ATTREQ 1) ;;;;system variable required for inserting attrobuted blocks
(setvar 'ATTDIA 0) ;;;;system variable required for inserting attrobuted blocks

  (if (setq ss (ssget '((0 . "LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
            pb (vlax-curve-getStartPoint en) ;;;;;gets start point of line or arc
            pe (vlax-curve-getEndPoint en)  ;;;;;gets end point of line or arc
            pm (if (= "ARC" (cdr (assoc 0 (entget en)))) ;;;;;Center point of arc
                 (cdr (assoc 10 (entget en)))
                 '(0 0 0)))

(setq Point2Process (List "pb" "pm" "pe"))
(while (/= Point2Process nil)

(setq PointX (rtos (car (eval (read (car Point2Process)))) 2 3))
(setq PointY (rtos (cadr (eval (read (car Point2Process)))) 2 3))
(setq PointZ (rtos (last (eval (read (car Point2Process)))) 2 3))

(setq PointsList (cons (strcat PointX "," PointY "," PointZ) PointsList))

(setq Point2Process (cdr point2process))
);end while 

);end repeat
);end if

(setq PointsList (bubblesort PointsList))
(setq PointsList (vl-remove "0.000,0.000,0.000" PointsList))

(command "_layer" "m" "CONTROL MARK" "")

(while (/= PointsList nil)

(command "_.-INSERT" "L:/Work/SUR/LIBRARY/AutoCAD Civil 3D/General Settings/LISP/Point Management/Pointblock.dwg" (car PointsList) "" "" "" "STN")

(setq PointsList (cdr PointsList))
);end while 

);end defun

You are also wasting time passing in variables as strings, then (eval (read..)) to get the variable, then converting the points list back to a string! (very slow). The insert command (slow) will accept a variable containing a point, there is no need to convert to a comma delimited string.

Where are you reading from a file or is closing the file in the local error just a remnant?

If you want a block inserted on the start and end point of a line just pass that point to the insert within the ss (repeat), the same with the center of the arc.

Edited May 12, 2020 by dlanorh

May 12, 2020

14 hours ago, marko_ribar said:

Sambo, what is (bubblesort pointlist) sub function?

Hmm i thought bubblesort was a visual lisp sub function. maybe its just in one of my other lisps . Its basically just a sorting algorithm that removes duplicates.

Edited May 13, 2020 by Sambo

May 13, 2020

Ahh ok, maybe i should go forward a few steps. I need the strings to write all these points to a csv. After i've fixed the speed issue ill open the file at the start of the repeat and the while loop where its inserting the block will look something like the below. This also explains the file error trap. I just took that code out for now because i didn't want to keep writing files during testing.

(while (/= PointsList nil)
(Setq PointSuffix (+ PointSuffix 1))
(write-line (strcat "S" PointSuffix "," (car PointsList "," "10500") file)
(command "_.-INSERT" "Pointblock" (car PointsList) "" "" "" (strcat "S" PointSuffix))
(setq PointsList (cdr PointsList))
);end while

On top of this i'm using the string list to remove duplicate points and points within the sub millimetre range from my points list with the bubblesort sub function. So if i passed the points to the insert within the ss (repeat) i wouldn't be removing the duplicates. For Example, where the start point of one line is the end point or start point of another line.

At the moment the runtime breakdown on a small estate (around 3000 - 6000 created blocks) is as follows:

- The entire script up to the while loop that inserts the block (1-5 Seconds)

- The while loop that inserts the block (about a minute to a minute and a half)

Do you think this might be because i'm using a string to insert the block? or is the insert command just naturally slow withing lisps? i thought about trying to insert the block through entmake. Do you think this would this speed up the runtime? or is there maybe a better way of doing it altogether?

I have now changed it to load the block file first and then just insert it. It hasn't sped up the runtime at all though.

(command "-insert" "Pointblock=L:/Work/SUR/LIBRARY/AutoCAD Civil 3D/General Settings/LISP/Point Management/Pointblock.dwg")
(command)

(while (/= PointsList nil)
(command "_.-INSERT" "Pointblock" (car PointsList) "" "" "" "STN")
(setq PointsList (cdr PointsList))
);end while

Block attached.

PointBlock.dwg

Edited May 13, 2020 by Sambo

May 13, 2020

This is not tested since I don't know what PointsList is, so idk if this will work or fail, but I do know that my sub function will work.

Seeing as how I analysed your code, maybe this will do the trick. Hopefully it works... <Again, this is not tested>

vla-insertblock normally takes time, but idk how else entmake will create the attributes... I'm not that skilled

(defun c:putblocks ( / atts blk blkname blkpath msp pointslist)
    (setq msp (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
	  blkpath "L:\\Work\\SUR\\LIBRARY\\AutoCAD Civil 3D\\General Settings\\LISP\\Point Management\\Pointblock.dwg"	; <-- the full filepath of the block to insert
	  blkname (vl-filename-base blkpath)
	  )
    (JH:InsertBlockToDrawing blkpath)
    (foreach x PointsList	; <--- Your points list here please
	(setq blk (vla-InsertBlock msp (vlax-3d-point x) blkname 1.0 1.0 1.0 0.0))
	(if (setq atts (vlax-invoke blk 'GetAttributes))
	    (vla-put-TextString (car atts) "STN")
	    )
	)
    (princ)
    )

;; JH:InsertBlockToDrawing --> Jonathan Handojo
;; Inserts a written block into a drawing if it hasn't already been inserted
;; path - the full filepath of the block to be inserted

(defun JH:InsertBlockToDrawing (path / *error* layobj stt tmp)
    (defun *error* (msg) (if tmp (entmod (subst (cons 70 stt) tmp (entget layobj)))))
    (if (null (tblsearch "block" (vl-filename-base path)))
	(progn
	    (if (/= 0 (setq stt (cdr (assoc 70 (entget (setq layobj (tblobjname "layer" (getvar 'clayer))))))))
		(entmod
		    (subst
			(setq tmp '(70 . 0))
			(assoc 70 (entget layobj))
			(entget layobj)
			)
		    )
		)
	    (vla-delete
		(vla-InsertBlock
		    (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		    (vlax-3d-point 0 0 0)
		    path 1.0 1.0 1.0 0.0
		    )
		)
	    (if tmp
		(entmod
		    (subst
			(cons 70 stt)
			tmp
			(entget layobj)
			)
		    )
		)
	    )
	)
    )

May 13, 2020

A question to Sambo why would you put a BLOCK with att "STN" to 10,000 points ? Are you sure your data file does not have more that your not telling us. If so let us know now, not when you ask for further enhancements after code is posted.

You can do a multisort of a list using Vl-sort for x y z etc. Is this what your Bubblesort does, for those oldies like me if you goggle bubblesort its a sorting method been around for ever, prior to Vl-sort I wrote a lisp bubblesort about 30 years ago.

May 13, 2020

1 hour ago, Sambo said:
Ahh ok, maybe i should go forward a few steps. I need the strings to write all these points to a csv. After i've fixed the speed issue ill open the file at the start of the repeat and the while loop where its inserting the block will look something like the below. This also explains the file error trap. I just took that code out for now because i didn't want to keep writing files during testing.
(while (/= PointsList nil)
(Setq PointSuffix (+ PointSuffix 1))
(write-line (strcat "S" PointSuffix "," (car PointsList "," "10500") file)
(command "_.-INSERT" "Pointblock" (car PointsList) "" "" "" (strcat "S" PointSuffix))
(setq PointsList (cdr PointsList))
);end while 
On top of this i'm using the string list to remove duplicate points and points within the sub millimetre range from my points list with the bubblesort sub function. So if i passed the points to the insert within the ss (repeat) i wouldn't be removing the duplicates. For Example, where the start point of one line is the end point or start point of another line.

At the moment the runtime breakdown on a small estate (around 3000 - 6000 created blocks) is as follows:

- The entire script up to the while loop that inserts the block (1-5 Seconds)

- The while loop that inserts the block (about a minute to a minute and a half)

Do you think this might be because i'm using a string to insert the block? or is the insert command just naturally slow withing lisps? i thought about trying to insert the block through entmake. Do you think this would this speed up the runtime? or is there maybe a better way of doing it altogether?

I have now changed it to load the block file first and then just insert it. It hasn't sped up the runtime at all though.
(command "-insert" "Pointblock=L:/Work/SUR/LIBRARY/AutoCAD Civil 3D/General Settings/LISP/Point Management/Pointblock.dwg")
(command)

(while (/= PointsList nil)
(command "_.-INSERT" "Pointblock" (car PointsList) "" "" "" "STN")
(setq PointsList (cdr PointsList))
);end while 
Block attached.

PointBlock.dwg 370.35 kB · 1 download

It would be quicker to save the points to a list checking for duplicates using the equal function with a fuzz factor. This should also cover any sub mm problems, but you would have to go into a bit more detail as to what that problem is. Convert coords to strings as you write the csv file.

IIRC, the insert command on the command line,infact any command, assumes everything is a string then converts what it needs back into the required integer, real, list etc. This is what makes "command" in a lisp 6-10 times slower. Creating entities with entmake is the fastest, followed closely by the vl add methods, vlax-invoke ??? and vla-add??? in that order. Vla-add is slightly slower as it again has some overheads.

I'm the other side of the world so i'll post a few pointer in the later today.

May 13, 2020

To Sambo again post your block, starting to understand you are looking at a co-ordinate dump of end of points. What happens to arcs ? Need centre pt ?

So would you not also want a ID number as well.

May 13, 2020

SAMBO you refer to lots is this a subdivision plan and you need all the corner points ? If so should have said so at post 1 as I have done that answer for multiple lots in one go a couple of versions.

May 14, 2020

Thank you so much everyone for your help and guidance! I implemented Jonathan Handojo's code and made some slight additions to the lisp. I also used vl-sort as suggested by BIGAL and dlanorh. The script now runs very quickly!

The only issue i have now is the fuzz factor on my sorting algorithm, when running the script vl-sort still doesn't seem to be removing sub mm points from my pointslist. Im guessing someone here will be able to tell me why and help me fix it? ill attach an example of the CSV file this script creates if you want to see what i mean, there's still a lot of duplicate points within the csv even after running vl-sort on the pointslist. Amended Lisp below.

To answer some of the other questions:

- "STN" was a placeholder before, i have now replaced it with an actual station number "S...".

- Yes its a subdivision co-ordinante dump for the field guys to go out and mark the points in the field. The CSV file is in the following format: Point number, Easting, Northing, RL, Point Code.

- Yes with arcs i needed the start point, end point and center point. The initial code already picked up these points.

- Yes its for Subdivisions. The lisp just creates a co-ordinated csv file and adds stations to the cad file so the field surveyors can print out a setout plan to help them mark the points when they are out in the field.

- I have attached my station block again as well for those who wanted it.

(vl-load-com)

(defun c:CREATEPOINTS () ; / *error* file i en pe pm pb)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
      (princ (strcat "\nError: " errmsg)))
    (if file (close file))
    (princ))

(setq PointsList nil)
(setvar 'ATTREQ 1) ;;;;system variable required for inserting attrobuted blocks
(setvar 'ATTDIA 0) ;;;;system variable required for inserting attrobuted blocks

  (if (setq ss (ssget '((0 . "LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq en (ssname ss (setq i (1- i)))
            pb (vlax-curve-getStartPoint en) ;;;;;gets start point of line or arc
            pe (vlax-curve-getEndPoint en)  ;;;;;gets end point of line or arc
            pm (if (= "ARC" (cdr (assoc 0 (entget en)))) ;;;;;Center point of arc
                 (cdr (assoc 10 (entget en)))
                 '(0 0 0)))

(setq Point2Process (List "pb" "pm" "pe"))
(while (/= Point2Process nil)

(if (= Pointslist nil)
(setq Pointslist (list (eval (read (car Point2Process)))))
(setq PointsList (append (list (eval (read (car Point2Process)))) Pointslist))
)

(setq Point2Process (cdr point2process))
);end while 

);end repeat
);end if

(setq pointslist (vl-sort pointslist 'compare-points))
(setq pointslist (vl-remove (list 0 0 0) pointslist))

(command "_layer" "m" "CONTROL MARK" "")
(putblocks)

(princ (strcat "\nFile exported: "(getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) " Ver " "AddVerHere" ".csv"))
(*error* "end")

);end defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Vl-sort sorting algorithim for 3D points

(defun-q compare-points (a b / fuzz)
     (setq fuzz 1.0e-3) ;; comparison precision
     (if (equal (car a) (car b) fuzz)
        (if (equal (cadr a) (cadr b) fuzz)
           (> (caddr a) (caddr b))
           (> (cadr a) (cadr b))
        )
        (> (car a) (car b))
     )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun putblocks ( / atts blk blkname blkpath msp Pointsuffix)
    (setq msp (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
      blkpath "L:\\Work\\SUR\\LIBRARY\\AutoCAD Civil 3D\\General Settings\\LISP\\Point Management\\Pointblock.dwg"    ; <-- the full filepath of the block to insert
      blkname (vl-filename-base blkpath)
      )
    (setq file (open (strcat (getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) " Ver " "AddVerHere" ".csv") "w"))
    (JH:InsertBlockToDrawing blkpath)
    (Setq Pointsuffix 0)
    (foreach x PointsList    ; <--- Your points list here please
        (Setq Pointsuffix (+ Pointsuffix 1))
        (setq PointX (rtos (car x) 2 3))
        (setq PointY (rtos (cadr x) 2 3))
        (setq PointZ (rtos (last x) 2 3))
        (write-line (strcat "S" (rtos pointsuffix 2 0) "," PointX "," PointY "," PointZ "," "10500") file)
    (setq blk (vla-InsertBlock msp (vlax-3d-point x) blkname 1.0 1.0 1.0 0.0))
    (if (setq atts (vlax-invoke blk 'GetAttributes))
        (vla-put-TextString (car atts) (strcat "S" (rtos pointsuffix 2 0)))
        )
    )
    (princ)
    )

;; JH:InsertBlockToDrawing --> Jonathan Handojo
;; Inserts a written block into a drawing if it hasn't already been inserted
;; path - the full filepath of the block to be inserted

(defun JH:InsertBlockToDrawing (path / *error* layobj stt tmp)
    (defun *error* (msg) (if tmp (entmod (subst (cons 70 stt) tmp (entget layobj)))))
    (if (null (tblsearch "block" (vl-filename-base path)))
    (progn
        (if (/= 0 (setq stt (cdr (assoc 70 (entget (setq layobj (tblobjname "layer" (getvar 'clayer))))))))
        (entmod
            (subst
            (setq tmp '(70 . 0))
            (assoc 70 (entget layobj))
            (entget layobj)
            )
            )
        )
        (vla-delete
        (vla-InsertBlock
            (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
            (vlax-3d-point 0 0 0)
            path 1.0 1.0 1.0 0.0
            )
        )
        (if tmp
        (entmod
            (subst
            (cons 70 stt)
            tmp
            (entget layobj)
            )
            )
        )
        )
    )
    )

PointBlock.dwg

Drawing2 Ver AddVerHere.csv

May 14, 2020

Ever heard of Unique with Fuzz from our good old legend? That may help you.

May 14, 2020

Just optimised your code to below:

(vl-load-com)

(defun c:CREATEPOINTS (/ *error* en file i pb pe pm pointslist ss)
    
    (defun *error* (errmsg)
	(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
	    (princ (strcat "\nError: " errmsg)))
	(if file (close file))
	(princ))
    
;;;    (setq PointsList nil)
    
    (setvar 'ATTREQ 1) ;;;;system variable required for inserting attrobuted blocks
    (setvar 'ATTDIA 0) ;;;;system variable required for inserting attrobuted blocks
    
    (if (setq ss (ssget '((0 . "LINE,ARC"))))
	(repeat (setq i (sslength ss))
	    (setq en (ssname ss (setq i (1- i)))
		  PointsList
		     (cons
			 (append
			     (list
				 (vlax-curve-getStartPoint en)
				 (vlax-curve-getEndPoint en)
				 )
			     (if (eq "ARC" (cdr (assoc 0 (entget en))))
				 (list (cdr (assoc 10 (entget en))))
				 )
			     )
			 PointsList
			 )
		  )
			     
;;;		  pb (vlax-curve-getStartPoint en) ;;;;;gets start point of line or arc
;;;		  pe (vlax-curve-getEndPoint en)  ;;;;;gets end point of line or arc
;;;		  pm (if (= "ARC" (cdr (assoc 0 (entget en)))) ;;;;;Center point of arc
;;;			 (cdr (assoc 10 (entget en)))
;;;			 '(0 0 0)))
;;;	    
;;;	    (setq Point2Process (List "pb" "pm" "pe"))
;;;	    (while (/= Point2Process nil)
;;;		
;;;		(if (= Pointslist nil)
;;;		    (setq Pointslist (list (eval (read (car Point2Process)))))
;;;		    (setq PointsList (append (list (eval (read (car Point2Process)))) Pointslist))
;;;		    )
;;;		
;;;		(setq Point2Process (cdr point2process))
;;;		);end while
	    
	    );end repeat
	);end if
    
    (setq pointslist (vl-sort (LM:UniqueFuzz (apply 'append pointslist) 1e-3) 'compare-points))
;;;    (setq pointslist (vl-remove (list 0 0 0) pointslist))
    
;;;    (command "_layer" "m" "CONTROL MARK" "")
    (setvar 'clayer "CONTROL MARK")
    (putblocks)
    
    (princ (strcat "\nFile exported: "(getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) " Ver " "AddVerHere" ".csv"))
    (*error* "end")
    
    );end defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Vl-sort sorting algorithim for 3D points

(defun-q compare-points (a b / fuzz)
	 ;(setq fuzz 1.0e-3) ;; comparison precision
	 (if (equal (car a) (car b) fuzz)
	     (if (equal (cadr a) (cadr b) fuzz)
		 (> (caddr a) (caddr b))
		 (> (cadr a) (cadr b))
		 )
	     (> (car a) (car b))
	     )
	 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun putblocks ( / atts blk blkname blkpath msp Pointsuffix)
    (setq msp (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
	  blkpath "L:\\Work\\SUR\\LIBRARY\\AutoCAD Civil 3D\\General Settings\\LISP\\Point Management\\Pointblock.dwg"    ; <-- the full filepath of the block to insert
	  blkname (vl-filename-base blkpath)
	  )
    (setq file (open (strcat (getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) " Ver " "AddVerHere" ".csv") "w"))
    (JH:InsertBlockToDrawing blkpath)
    (Setq Pointsuffix 0)
    (foreach x PointsList    ; <--- Your points list here please
	(Setq Pointsuffix (+ Pointsuffix 1))
;;;	(setq PointX (rtos (car x) 2 3)) 
;;;	(setq PointY (rtos (cadr x) 2 3))
;;;	(setq PointZ (rtos (last x) 2 3))
;;;	(write-line (strcat "S" (rtos pointsuffix 2 0) "," PointX "," PointY "," PointZ "," "10500") file)
	(write-line
	    (JH:lst->str
		(append
		    (list (strcat "S" (itoa Pointsuffix)))
		    (mapcar 'rtos x '(2 2 2) '(3 3 3))
		    '("10500")
		    )
		","
		)
	    file
	    )
	(setq blk (vla-InsertBlock msp (vlax-3d-point x) blkname 1.0 1.0 1.0 0.0))
	(if (setq atts (vlax-invoke blk 'GetAttributes))
	    (vla-put-TextString (car atts) (strcat "S" (rtos pointsuffix 2 0)))
	    )
	)
    (princ)
    )

;; JH:InsertBlockToDrawing --> Jonathan Handojo
;; Inserts a written block into a drawing if it hasn't already been inserted
;; path - the full filepath of the block to be inserted

(defun JH:InsertBlockToDrawing (path / *error* layobj stt tmp)
    (defun *error* (msg) (if tmp (entmod (subst (cons 70 stt) tmp (entget layobj)))))
    (if (null (tblsearch "block" (vl-filename-base path)))
	(progn
	    (if (/= 0 (setq stt (cdr (assoc 70 (entget (setq layobj (tblobjname "layer" (getvar 'clayer))))))))
		(entmod
		    (subst
			(setq tmp '(70 . 0))
			(assoc 70 (entget layobj))
			(entget layobj)
			)
		    )
		)
	    (vla-delete
		(vla-InsertBlock
		    (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		    (vlax-3d-point 0 0 0)
		    path 1.0 1.0 1.0 0.0
		    )
		)
	    (if tmp
		(entmod
		    (subst
			(cons 70 stt)
			tmp
			(entget layobj)
			)
		    )
		)
	    )
	)
    )

;; JH:lst->str --> Jonathan Handojo
;; Concatenates a list of string into one string with a specified delimeter
;; lst - list of strings
;; del - delimiter string

(defun JH:lst->str (lst del)
    (apply 'strcat (append (list (car lst)) (mapcar '(lambda (x) (strcat del x)) (cdr lst))))
    )

;; Unique with Fuzz  -  Lee Mac
;; Returns a list with all elements considered duplicate to
;; a given tolerance removed.

(defun LM:UniqueFuzz ( l f / x r )
    (while l
        (setq x (car l)
              l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

May 14, 2020

@Jonathan Handojo I would personally advise against this approach:

	    (if (/= 0 (setq stt (cdr (assoc 70 (entget (setq layobj (tblobjname "layer" (getvar 'clayer))))))))
		(entmod
		    (subst
			(setq tmp '(70 . 0))
			(assoc 70 (entget layobj))
			(entget layobj)
			)
		    )
		)

DXF group 70 is a bit-coded value, and should therefore be manipulated as such so as to remove only the relevant bit codes (in this case, bit 4), as some codes are used internally by AutoCAD as indicators (e.g. bit codes 16/32/64) whereby the presence/absence of the bit code is driven by another process, no the other way around.

Edited May 14, 2020 by Lee Mac

May 14, 2020

Sambo don't need blocks or if you must, if each lot has a text id within it then you can use bpoly to make a pline of the enclosed area it will auto find lots based on the text you can then get co-ords make a list, you can also check for bulge/arc and get center point. Then do a sort and remove duplicates much easier than getting all lines and checking 2 points for duplicates.

Again when posting request its best to fully describe what your trying to do with a image or dwg.

Here is a couple of programs that may be usefull.

Dolots 2 layout.lsp Dolots.lsp

Edited May 14, 2020 by BIGAL

May 16, 2020

On 5/15/2020 at 2:45 AM, Lee Mac said:
@Jonathan Handojo I would personally advise against this approach:
	    (if (/= 0 (setq stt (cdr (assoc 70 (entget (setq layobj (tblobjname "layer" (getvar 'clayer))))))))
		(entmod
		    (subst
			(setq tmp '(70 . 0))
			(assoc 70 (entget layobj))
			(entget layobj)
			)
		    )
		)
DXF group 70 is a bit-coded value, and should therefore be manipulated as such so as to remove only the relevant bit codes (in this case, bit 4), as some codes are used internally by AutoCAD as indicators (e.g. bit codes 16/32/64) whereby the presence/absence of the bit code is driven by another process, no the other way around.

Not that I've actually seen one whose values are anything other than 0, 1, 4, and 5, each combination of which denotes if the layer is locked or frozen. Sometimes I do use logand to account only for locked layers and ignore frozen ones or sort... but if you say so, then okay

May 20, 2020

On 14/05/2020 at 19:35, Jonathan Handojo said:

Just optimised your code to below:


(vl-load-com)

(defun c:CREATEPOINTS (/ *error* en file i pb pe pm pointslist ss)
    
    (defun *error* (errmsg)
	(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
	    (princ (strcat "\nError: " errmsg)))
	(if file (close file))
	(princ))
    
;;;    (setq PointsList nil)
    
    (setvar 'ATTREQ 1) ;;;;system variable required for inserting attrobuted blocks
    (setvar 'ATTDIA 0) ;;;;system variable required for inserting attrobuted blocks
    
    (if (setq ss (ssget '((0 . "LINE,ARC"))))
	(repeat (setq i (sslength ss))
	    (setq en (ssname ss (setq i (1- i)))
		  PointsList
		     (cons
			 (append
			     (list
				 (vlax-curve-getStartPoint en)
				 (vlax-curve-getEndPoint en)
				 )
			     (if (eq "ARC" (cdr (assoc 0 (entget en))))
				 (list (cdr (assoc 10 (entget en))))
				 )
			     )
			 PointsList
			 )
		  )
			     
;;;		  pb (vlax-curve-getStartPoint en) ;;;;;gets start point of line or arc
;;;		  pe (vlax-curve-getEndPoint en)  ;;;;;gets end point of line or arc
;;;		  pm (if (= "ARC" (cdr (assoc 0 (entget en)))) ;;;;;Center point of arc
;;;			 (cdr (assoc 10 (entget en)))
;;;			 '(0 0 0)))
;;;	    
;;;	    (setq Point2Process (List "pb" "pm" "pe"))
;;;	    (while (/= Point2Process nil)
;;;		
;;;		(if (= Pointslist nil)
;;;		    (setq Pointslist (list (eval (read (car Point2Process)))))
;;;		    (setq PointsList (append (list (eval (read (car Point2Process)))) Pointslist))
;;;		    )
;;;		
;;;		(setq Point2Process (cdr point2process))
;;;		);end while
	    
	    );end repeat
	);end if
    
    (setq pointslist (vl-sort (LM:UniqueFuzz (apply 'append pointslist) 1e-3) 'compare-points))
;;;    (setq pointslist (vl-remove (list 0 0 0) pointslist))
    
;;;    (command "_layer" "m" "CONTROL MARK" "")
    (setvar 'clayer "CONTROL MARK")
    (putblocks)
    
    (princ (strcat "\nFile exported: "(getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) " Ver " "AddVerHere" ".csv"))
    (*error* "end")
    
    );end defun


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Vl-sort sorting algorithim for 3D points

(defun-q compare-points (a b / fuzz)
	 ;(setq fuzz 1.0e-3) ;; comparison precision
	 (if (equal (car a) (car b) fuzz)
	     (if (equal (cadr a) (cadr b) fuzz)
		 (> (caddr a) (caddr b))
		 (> (cadr a) (cadr b))
		 )
	     (> (car a) (car b))
	     )
	 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun putblocks ( / atts blk blkname blkpath msp Pointsuffix)
    (setq msp (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
	  blkpath "L:\\Work\\SUR\\LIBRARY\\AutoCAD Civil 3D\\General Settings\\LISP\\Point Management\\Pointblock.dwg"    ; <-- the full filepath of the block to insert
	  blkname (vl-filename-base blkpath)
	  )
    (setq file (open (strcat (getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) " Ver " "AddVerHere" ".csv") "w"))
    (JH:InsertBlockToDrawing blkpath)
    (Setq Pointsuffix 0)
    (foreach x PointsList    ; <--- Your points list here please
	(Setq Pointsuffix (+ Pointsuffix 1))
;;;	(setq PointX (rtos (car x) 2 3)) 
;;;	(setq PointY (rtos (cadr x) 2 3))
;;;	(setq PointZ (rtos (last x) 2 3))
;;;	(write-line (strcat "S" (rtos pointsuffix 2 0) "," PointX "," PointY "," PointZ "," "10500") file)
	(write-line
	    (JH:lst->str
		(append
		    (list (strcat "S" (itoa Pointsuffix)))
		    (mapcar 'rtos x '(2 2 2) '(3 3 3))
		    '("10500")
		    )
		","
		)
	    file
	    )
	(setq blk (vla-InsertBlock msp (vlax-3d-point x) blkname 1.0 1.0 1.0 0.0))
	(if (setq atts (vlax-invoke blk 'GetAttributes))
	    (vla-put-TextString (car atts) (strcat "S" (rtos pointsuffix 2 0)))
	    )
	)
    (princ)
    )

;; JH:InsertBlockToDrawing --> Jonathan Handojo
;; Inserts a written block into a drawing if it hasn't already been inserted
;; path - the full filepath of the block to be inserted

(defun JH:InsertBlockToDrawing (path / *error* layobj stt tmp)
    (defun *error* (msg) (if tmp (entmod (subst (cons 70 stt) tmp (entget layobj)))))
    (if (null (tblsearch "block" (vl-filename-base path)))
	(progn
	    (if (/= 0 (setq stt (cdr (assoc 70 (entget (setq layobj (tblobjname "layer" (getvar 'clayer))))))))
		(entmod
		    (subst
			(setq tmp '(70 . 0))
			(assoc 70 (entget layobj))
			(entget layobj)
			)
		    )
		)
	    (vla-delete
		(vla-InsertBlock
		    (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		    (vlax-3d-point 0 0 0)
		    path 1.0 1.0 1.0 0.0
		    )
		)
	    (if tmp
		(entmod
		    (subst
			(cons 70 stt)
			tmp
			(entget layobj)
			)
		    )
		)
	    )
	)
    )

;; JH:lst->str --> Jonathan Handojo
;; Concatenates a list of string into one string with a specified delimeter
;; lst - list of strings
;; del - delimiter string

(defun JH:lst->str (lst del)
    (apply 'strcat (append (list (car lst)) (mapcar '(lambda (x) (strcat del x)) (cdr lst))))
    )

;; Unique with Fuzz  -  Lee Mac
;; Returns a list with all elements considered duplicate to
;; a given tolerance removed.

(defun LM:UniqueFuzz ( l f / x r )
    (while l
        (setq x (car l)
              l (vl-remove-if (function (lambda ( y ) (equal x y f))) (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

Thanks Jonathan, has this been tested already? i cant seem to get it to work or figure out why its not working

I also tried to just segment out the sorting algorithm out and add it to my working script and i couldn't make that work either. i'm still quiet new to this.

May 20, 2020

Sambo you did not answer my question wether this is to do with subdivision plans can export out P E N Z D the description would be say L123 for lot 123 a better way in the field of knowing what point is associated with what lot. Would also mean the setout is done in lot order rather than random point order even though sorted.

Sign In

Speed up Lisp on block insert

Recommended Posts

Sambo

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Jonathan Handojo

BIGAL

dlanorh

Aftertouch

dlanorh

marko_ribar

dlanorh

Sambo

Sambo

Jonathan Handojo

BIGAL

dlanorh

BIGAL

BIGAL

Sambo

Jonathan Handojo

Jonathan Handojo

Lee Mac

BIGAL

Jonathan Handojo

Sambo

BIGAL

Join the conversation

Jonathan Handojo

BIGAL

dlanorh

Tutorials

Forums

Activity