Lisp to draw 3D points from 2D position and level text

[dlbsurveysuk]

Hi, I've slightly modified some code found here https://www.cadtutor.net/forum/topic/67754-list-of-coordinate-with-nearest-text/ to produce this -

(defun c:pctt ( / points texts i j pt ind dst d result)

  (setq points (ssget "_X" (list (cons 8 "LX"))))
  (setq texts  (ssget "_X" (list (cons 0 "TEXT")))) 
  (setq i 0)
  (setq result (list))

  (repeat (sslength points)
      (setq j 0)
      (setq dst nil)  ;; Closest dist.  If a new closer dist is found we replace dst by that new value
      (setq ind nil)

           (repeat (sslength texts)
               (setq d (distance
                  (setq pt (cdr (assoc 10 (entget (ssname points i)))))            ;; insert point of the point
                  (cdr (assoc 10 (entget (ssname texts j))))                            ;; insert point of the text
         	 	  )
               )

    	    (if (or (= dst nil) (< d dst))
	  	(progn
      	   	  (setq dst d)
      	  	  (setq ind j)
      		)
     	    )
	 
               (setq j (+ j 1))
           );repeat
    
         (setq result (append result (list
            (list
              (nth 0 pt)                                                                                  ;; x value of point
              (nth 1 pt)                                                                                  ;; y value of point
              (atof (cdr (assoc 1 (entget (ssname texts ind)))))                    ;; text to number ?
            )
         )))
    
    (setq i (+ i 1))
  );repeat

         (if result
             (foreach xyzlist result
                   (command "POINT" xyzlist)
                   (princ xyzlist)
             )
         )
(princ )
)

The idea is to draw 3d points at all cross insertions, that have a z value of the nearest text.

Test drawing attached.

The command line output shows the correct z values but the drawn points all have z=0.

I can't see what is wrong. I'm sure it's something obvious that I'm missing...

Thanks.

[komondormrex]

hi,

all texts in posted test file have zero z coordinates.

[dlbsurveysuk]

Yes, correct. The idea is to convert the nearest text to every cross to a numerical value and use that as the z value for drawing a point.

[dlbsurveysuk]

I've written this that accomplishes the correct result by picking the crosses and text manually one by one. I'm hoping the OP routine will accomplish it in one fell swoop (the overall reason for this is that, if I'm given a 2D drawing with levels I can auto create 3D level points to feed to a contour drawing program).

(defun c:3DNODES ()

         (defun *error* (MSG)

            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))

              (if osm (setvar "OSMODE" OSM))
              (if lyr (setvar "CLAYER" LYR))

          (princ) )

(setvar "cmdecho" 0)
(setq OSM   (GETVAR "OSMODE"))
(setq LYR   (GETVAR "CLAYER"))
(setvar "CLAYER" "GROUND-LINE")

   (command "OSNAP" "INTERSECTION")
  
      (while

         (setq XYpoint (getpoint "XYpoint...?"))

         (command "OSNAP" "NONE")

         (setq Picktext (car (entsel "Level text...?")))
         (setq Znumber (atof (vla-get-textstring (vlax-ename->vla-object Picktext))))

         (setq XYZpoint (list (car XYpoint) (cadr XYpoint) Znumber))    
         (command "_POINT" XYZpoint)

         (command "OSNAP" "INTERSECTION")
     
      )
  
(setvar "OSMODE" OSM)
(command "LAYER" "S" LYR "")
(princ)
)


     

[komondormrex]

opps, sure, missed the point(

[komondormrex · Accepted solution]

it is snapping then)

(command "POINT" "_non" xyzlist) would actually do better)

[dlbsurveysuk]

Ah brilliant. That works now. I knew it was something simple/silly. Gotta watch out for those snaps!

Thanks very much.

[komondormrex]

your welcome) 

that is why vla-adding entities is much steadier.

[Sea-Haven · Accepted solution]

Did not see a final code so I would do this method, use a polygon to search for text. The center point is the Insertion point of CROSS, you actually dont make a polygon but make a list of points then use (ssget "F" method to get the text. Then a POINT with correct Z at insertion point.

Another hint is as text position is fixed can make the search box a lot simpler.

[dlbsurveysuk]

Hi, thanks for the suggestion.

I got my original code working by implementing Komondormrex' suggestion re no snaps. The problem is that this only works successfully if cross and text are well spaced from other crosses and texts, as it finds the nearest text by insertion point. So if things are cluttered as in the attached test drawing no.2 it's a big fail with incorrect z values all over the place.

So I've implemented your idea but with a square polygon and using ssget "_CP" instead of "F". The size of the square is defined as a multiple of the textsize. If the the ssget "_CP" selects more than one text object the square is gradually reduced in size until only one text object is selected.

The code works almost perfectly on the test drawing and only fails on one cross where another crosses text is nearer. I can't think of a way around this at the moment...

It also takes a while to compute...

Thanks for steering me onto the right path.

(defun c:M3DT (/ INX I PROXLIST INENAME INP PROXTEXT)

         (defun *error* (MSG)

            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))

              (if osm (setvar "OSMODE" OSM))
              (if lyr (setvar "CLAYER" LYR))

          (princ) )

  (command "._UNDO" "_Begin")

  (setvar "cmdecho" 0)
  
  (setq OSM (GETVAR "OSMODE"))
  (setq LYR (GETVAR "CLAYER"))

	(vl-load-com)
	(setq   acadDocument (vla-get-activedocument (vlax-get-acad-object))
		theLayers (vla-get-layers acadDocument)
		newLayer (vla-add theLayers "PTS3D"))
	(vla-put-color newLayer 1)
	(vla-put-linetype newLayer "Continuous")

  (setvar "CLAYER" "PTS3D")

  (setq TXTS (getvar "TEXTSIZE"))

(defun mkreclist (INP SEARCHDIST)
	(list
		 (list (- (car INP) SEARCHDIST) (- (cadr INP) SEARCHDIST))
		 (list (- (car INP) SEARCHDIST) (+ (cadr INP) SEARCHDIST))
		 (list (+ (car INP) SEARCHDIST) (+ (cadr INP) SEARCHDIST))
		 (list (+ (car INP) SEARCHDIST) (- (cadr INP) SEARCHDIST))
	)
)

     (if     (setq INX (ssget ":S" '((2 . "CROSS")))
		I -1)

         (progn

   	     (repeat (sslength INX)

		(setq SFACT 3.50)  ;;; search distance factor - controls size of rectangular search area as multiple of textsize

		(setq   INENAME (ssname INX (setq I (1+ I)))
			INP (cdr (assoc 10 (entget INENAME)))
		      
			PROXTEXT (ssget "_CP" (mkreclist INP (* TXTS SFACT)) '((0 . "text")))
	 	 )
	       
			(if PROXTEXT
			  
			    (progn
			      
                                (setq COUNT (sslength PROXTEXT))

                                (while (> COUNT 1)
                                       (setq SFACT (- SFACT 0.02))  ;;; gradually reduce search area until only one text object selected
                                       (setq PROXTEXT (ssget "_CP" (mkreclist INP (* TXTS SFACT)) '((0 . "text"))))
                                       (setq COUNT (sslength PROXTEXT))
                                 );while
			    );progn
			);if

		     (if PROXTEXT

		          (setq PROXLIST (append PROXLIST
					     (list
						(list (nth 0 INP) (nth 1 INP) (atof (cdr (assoc 1 (entget (ssname PROXTEXT 0)))))
						)
					     )
					 )
			  )

		     );if
	      );repeat
          );progn
      );if

         (if PROXLIST
             (foreach xyzlist PROXLIST
             (command "POINT" "_non" (print xyzlist))
                   (princ xyzlist)
             )
         )
      
(setvar "OSMODE" OSM)
(command "LAYER" "S" LYR "")

(command "._UNDO" "_End")

(princ)
)

[Kent1Cooper]

[For the future, if you have control over the methodology, this is a good argument for using a Block with an Attribute, rather than separate Blocks and Text objects.]

[Sea-Haven]

Having worked Civil for too many years the output is possibly controlled by some software and a block option may not be available, eg CIV3D etc using label styles. They are proxy objects so can get each items properties.

dlbsurveysuk as the output is a X and text at a fixed relative position, then maybe a simpler a fence option looking for the text.

[dlbsurveysuk]

Kent1Cooper and Sea-Haven, this code is for random drawings/surveys (sometimes just a pdf) that an architect might send me asking if I can contour them (I think they find 3D contours useful for using in Sketchup/Revit). I have no control over them, they are usually 2D, and the text could be anywhere around each corresponding cross (see test drawing no2 above, this is because the original surveyor has positioned/moved the text so as not to overlap/interfere with other linework). Sometimes the text and crosses could be on the same layer, and sometimes the cross is not even a block.

[Sea-Haven]

One thing you can do where the text has not been moved but is relative to the X, is move all the text by the offset from the X, then use the insertion point of the text plus the text as the Z value. So no get 2 values. Yes have done what your doing.

[dlbsurveysuk]

I've managed to figure out how to use a octagon instead of a rectangle for ssget "CP".

Everything works as required but the "octagon search" code appears twice in the routine. I can't figure out how to make this code a separate function as the "rectangle search" code (mkREClist) was before.

Does anyone have any ideas how I might achieve this? Thanks.

(defun c:M3D (/ INX i ii PROXLIST INENAME INP PROXTEXT)

         (defun *error* (MSG)

            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))

              (if osm (setvar "OSMODE" OSM))
              (if lyr (setvar "CLAYER" LYR))

          (princ) )

  (command "._UNDO" "_Begin")

  (setvar "cmdecho" 0)
  
  (setq OSM (GETVAR "OSMODE"))
  (setq LYR (GETVAR "CLAYER"))

	(vl-load-com)

	(setq   acadDocument (vla-get-activedocument (vlax-get-acad-object))
		theLayers (vla-get-layers acadDocument)
		newLayer (vla-add theLayers "PTS3D"))
	(vla-put-color newLayer 1)
	(vla-put-linetype newLayer "Continuous")

	(setq   acadDocument (vla-get-activedocument (vlax-get-acad-object))
		theLayers (vla-get-layers acadDocument)
		newLayer (vla-add theLayers "AQUERY"))
	(vla-put-color newLayer 2)
	(vla-put-linetype newLayer "Continuous")


  (setvar "CLAYER" "PTS3D")

  (setq TXTS (getvar "TEXTSIZE"))

     (if     (setq INX (ssget ":S" '((8 . "LX")))
	      i -1)

         (progn

   	     (repeat (sslength INX)

                	(setq SFACT 3.50)  ;;; search distance factor - controls size of  search area as multiple of textsize

		(setq   INENAME (ssname INX (setq i (1+ i)))
		           INP (cdr (assoc 10 (entget INENAME)))
		)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;OCTAGON SEARCH;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

   (progn

      (setq OCTLIST nil)
      (setq ii 0)

      (while (< ii 8)
         (setq ii (1+ ii))
         (setq OCTLIST (append OCTLIST
             (list
               (list (+ (car INP) ( * (* TXTS SFACT) (sin (* ii (/ pi 4)))))
                      (+ (cadr INP) (* (* TXTS SFACT) (cos (* ii (/ pi 4)))))
               );list
             );list
          ));setq
       );while

   );progn

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

		          (setq PROXTEXT (ssget "_CP" OCTLIST '((8 . "LTEXT"))))

                                    ;;;;;;;;;;;;; PROXTEXT (ssget "_CP" (mkREClist INP (* TXTS SFACT) ) '((8 . "LTEXT")));;;;;;;;;;;;;

	 	 
	       
			(if PROXTEXT
			  
			    (progn
			      
                                                    (setq COUNT (sslength PROXTEXT))

                                                        (while (> COUNT 1)
                                                             (setq SFACT (- SFACT 0.02))  ;;; reduce search area until only one text object selected

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;OCTAGON SEARCH;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (progn

      (setq OCTLIST nil)
      (setq ii 0)

      (while (< ii 8)
         (setq ii (1+ ii))
         (setq OCTLIST (append OCTLIST
             (list
               (list (+ (car INP) ( * (* TXTS SFACT) (sin (* ii (/ pi 4)))))
                      (+ (cadr INP) (* (* TXTS SFACT) (cos (* ii (/ pi 4)))))
               );list
             );list
          ));setq
       );while

   );progn

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

                                                             (setq PROXTEXT (ssget "_CP" OCTLIST '((0 . "text"))))

                                           ;;;;;;;;;;;;;;;;; (setq PROXTEXT (ssget "_CP" (mkREClist INP (* TXTS SFACT)) '((0 . "text"))));;;;;;;;;;;;;;

                                                             (setq COUNT (sslength PROXTEXT))
                                                        );while

			    );progn

			    (progn

			       (setvar "CLAYER" "AQUERY")
			       (command "CIRCLE" INP (* 8 TXTS))
			       (setvar "CLAYER" "PTS3D")

			    );progn
			);if

		     (if PROXTEXT

		            (setq PROXLIST (append PROXLIST
					     (list
						(list
                                                                                                    (nth 0 INP)
                                                                                                    (nth 1 INP)
                                                                                                    (atof (cdr (assoc 1 (entget (ssname PROXTEXT 0)))))
						)
					     )
		            ))

		     );if
	      );repeat
          );progn
      );if

         (if PROXLIST
             (foreach xyzlist PROXLIST
             (command "POINT" "_non" (princ xyzlist))
             )
         )
      
(setvar "OSMODE" OSM)
(command "LAYER" "S" LYR "")

(command "._UNDO" "_End")

(princ)
)

;;*********************************RECTANGLE SEARCH*********************************

;;(defun mkREClist (INP SEARCHDIST)
;;	(list
;;		 (list (- (car INP) SEARCHDIST) (- (cadr INP) SEARCHDIST))
;;		 (list (- (car INP) SEARCHDIST) (+ (cadr INP) SEARCHDIST))
;;		 (list (+ (car INP) SEARCHDIST) (+ (cadr INP) SEARCHDIST))
;;		 (list (+ (car INP) SEARCHDIST) (- (cadr INP) SEARCHDIST))
;;	)
;;)

[komondormrex · Accepted solution]

it may be like that

(defun octagon_list (insertion_point txts sfact)
	(mapcar '(lambda (_angle) (polar insertion_point _angle (* txts sfact)))
			 (mapcar '*
			 	(list 0 (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4))
			   '(0 1 2 3 4 5 6 7)
			 )
	)     
)

[dlbsurveysuk]

Thanks for the response. Your code looks to be far more efficient. I must learn to use mapcar & lambda!

I've implemented your code but am getting "Error: bad point argument".

I don't fully understand the syntax for how variables are passed to the function...

(defun c:M3D (/ INX i ii PROXLIST INENAME INP PROXTEXT)

         (defun *error* (MSG)

            (if (/= MSG "Function cancelled")
                (princ (strcat "\nError: " MSG)))

              (if osm (setvar "OSMODE" OSM))
              (if lyr (setvar "CLAYER" LYR))

          (princ) )

  (command "._UNDO" "_Begin")

  (setvar "cmdecho" 0)
  
  (setq OSM (GETVAR "OSMODE"))
  (setq LYR (GETVAR "CLAYER"))

	(vl-load-com)

	(setq   acadDocument (vla-get-activedocument (vlax-get-acad-object))
		theLayers (vla-get-layers acadDocument)
		newLayer (vla-add theLayers "PTS3D"))
	(vla-put-color newLayer 1)
	(vla-put-linetype newLayer "Continuous")

	(setq   acadDocument (vla-get-activedocument (vlax-get-acad-object))
		theLayers (vla-get-layers acadDocument)
		newLayer (vla-add theLayers "AQUERY"))
	(vla-put-color newLayer 2)
	(vla-put-linetype newLayer "Continuous")


  (setvar "CLAYER" "PTS3D")

  (setq TXTS (getvar "TEXTSIZE"))

     (if     (setq INX (ssget ":S" '((8 . "LX")))
	      i -1)

         (progn

   	     (repeat (sslength INX)

                	(setq SFACT 3.50)  ;;; search distance factor - controls size of  search area as multiple of textsize

		(setq   INENAME (ssname INX (setq i (1+ i)))
		           INP (cdr (assoc 10 (entget INENAME)))
		)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;OCTAGON SEARCH;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;   (progn

;;      (setq OCTLIST nil)
;;      (setq ii 0)

 ;;     (while (< ii 8)
;;         (setq ii (1+ ii))
 ;;        (setq OCTLIST (append OCTLIST
;;             (list
;;               (list (+ (car INP) ( * (* TXTS SFACT) (sin (* ii (/ pi 4)))))
;;                      (+ (cadr INP) (* (* TXTS SFACT) (cos (* ii (/ pi 4)))))
;;               );list
;;             );list
 ;;         ));setq
;;       );while

;;   );progn

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

		          (setq PROXTEXT (ssget "_CP" octagon_list '((8 . "LTEXT"))))

                                    ;;;;;;;;;;;;; PROXTEXT (ssget "_CP" (mkREClist INP (* TXTS SFACT) ) '((8 . "LTEXT")));;;;;;;;;;;;;

	 	 
	       
			(if PROXTEXT
			  
			    (progn
			      
                                                    (setq COUNT (sslength PROXTEXT))

                                                        (while (> COUNT 1)
                                                             (setq SFACT (- SFACT 0.02))  ;;; reduce search area until only one text object selected

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;OCTAGON SEARCH;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;  (progn

;;      (setq OCTLIST nil)
;;      (setq ii 0)

;;      (while (< ii 8)
;;         (setq ii (1+ ii))
;;         (setq OCTLIST (append OCTLIST
;;             (list
;;               (list (+ (car INP) ( * (* TXTS SFACT) (sin (* ii (/ pi 4)))))
;;                      (+ (cadr INP) (* (* TXTS SFACT) (cos (* ii (/ pi 4)))))
;;               );list
;;             );list
;;          ));setq
;;       );while

;;   );progn

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

                                                             (setq PROXTEXT (ssget "_CP" octagon_list '((0 . "text"))))

                                           ;;;;;;;;;;;;;;;;; (setq PROXTEXT (ssget "_CP" (mkREClist INP (* TXTS SFACT)) '((0 . "text"))));;;;;;;;;;;;;;

                                                             (setq COUNT (sslength PROXTEXT))
                                                        );while

			    );progn

			    (progn

			       (setvar "CLAYER" "AQUERY")
			       (command "CIRCLE" INP (* 8 TXTS))
			       (setvar "CLAYER" "PTS3D")

			    );progn
			);if

		     (if PROXTEXT

		            (setq PROXLIST (append PROXLIST
					     (list
						(list
                                                                                                    (nth 0 INP)
                                                                                                    (nth 1 INP)
                                                                                                    (atof (cdr (assoc 1 (entget (ssname PROXTEXT 0)))))
						)
					     )
		            ))

		     );if
	      );repeat
          );progn
      );if

         (if PROXLIST
             (foreach xyzlist PROXLIST
             (command "POINT" "_non" xyzlist)
             )
         )
      
(setvar "OSMODE" OSM)
(command "LAYER" "S" LYR "")

(command "._UNDO" "_End")

(princ)
)

;;*********************************RECTANGLE SEARCH*********************************

;;(defun mkREClist (INP SEARCHDIST)
;;	(list
;;		 (list (- (car INP) SEARCHDIST) (- (cadr INP) SEARCHDIST))
;;		 (list (- (car INP) SEARCHDIST) (+ (cadr INP) SEARCHDIST))
;;		 (list (+ (car INP) SEARCHDIST) (+ (cadr INP) SEARCHDIST))
;;		 (list (+ (car INP) SEARCHDIST) (- (cadr INP) SEARCHDIST))
;;	)
;;)

(defun octagon_list (insertion_point txts sfact)
	(mapcar '(lambda (_angle) (polar insertion_point _angle (* txts sfact)))
			 (mapcar '*
			 	(list 0 (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4) (/ pi 4))
			   '(0 1 2 3 4 5 6 7)
			 )
	)     
)

[komondormrex]

it should be called this way

(ssget "_cp" (octagon_list INP TXTS SFACT) '((8 . "ltext")))

[dlbsurveysuk]

OK thanks very much. All working.

Trying to understand the way the variables work...

So the function is called using - (octagon_list INP TXTS SFACT)

and the function is defined - (defun octagon_list (insertion_point txts sfact)

Why is "INP" called "insertion_point"? Does the called function just assign the variables in the order they are encountered?

Thanks.

[komondormrex]

So the function is called using - (octagon_list INP TXTS SFACT)

and the function is defined - (defun octagon_list (insertion_point txts sfact)

---

you may name variables any way you like, i just left your way, partially

---

Why is "INP" called "insertion_point"? Does the called function just assign the variables in the order they are encountered?

---

because it is the block's insertion point. as i said you may name variables as you like.

yep, function assign variables in order they appear in according defun.