Solved: Please help me write LISP

chan230984 · ‎05-19-2019

I want to click Point 3 Point A,B,C

and I want to show table coordinate Northing and Easting (text height = 0.16)

Picture below

thanks

CADaSchtroumpf · ‎05-19-2019

Try this if can be usefull

(vl-load-com)
(defun c:points2cell ( / js AcDoc Space nw_style oldim oldlay ins_pt_cell h_t w_c lst_id-seg lst_pt n
                         obj dxf_10 nb nw_obj ename_cell n_row n_column)
  (princ "\nSelect points.")
  (while (null (setq js (ssget '((0 . "POINT")))))
    (princ "\nSelection empty, or is not a point!")
  )
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
  )
  (cond
    ((null (tblsearch "LAYER" "Table-Points"))
      (vla-add (vla-get-layers AcDoc) "Table-Points")
    )
  )
  (cond
    ((null (tblsearch "STYLE" "Text-Cell"))
      (setq nw_style (vla-add (vla-get-textstyles AcDoc) "Text-Cell"))
      (mapcar
        '(lambda (pr val)
          (vlax-put nw_style pr val)
        )
        (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
        (list (strcat (getenv "windir") "\\fonts\\arial.ttf") 0.0 (/ (* 15.0 pi) 180) 1.0 0.0)
      )
      (command "_.ddunits"
        (while (not (zerop (getvar "cmdactive")))
          (command pause)
        )
      )
    )
  )
  (setq
    oldim (getvar "dimzin")
    oldlay (getvar "clayer")
  )
  (setvar "dimzin" 0) (setvar "clayer" "Table-Points")
  (initget 9)
  (setq ins_pt_cell (getpoint "\nLeft-Up insert point of table: "))
  (initget 6)
  (setq h_t (getdist ins_pt_cell (strcat "\nHigth text <" (rtos (getvar "textsize")) ">: ")))
  (if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t))
  (initget 7)
  (setq w_c (getdist ins_pt_cell "\nWidth of cells: "))
  (setq
    lst_id-seg '()
    lst_pt '()
    nb 0
  )
  (repeat (setq n (sslength js))
    (setq
      obj (ssname js (setq n (1- n)))
      dxf_10 (cdr (assoc 10 (entget obj)))
      lst_pt (cons dxf_10 lst_pt)
      nb (1+ nb)
      lst_id-seg (cons nb lst_id-seg)
    )
  )
  (mapcar
    '(lambda (p tx)
      (setq nw_obj
        (vla-addMtext Space
          (vlax-3d-point p)
          0.0
          tx
        )
      )
      (mapcar
        '(lambda (pr val)
          (vlax-put nw_obj pr val)
        )
        (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
        (list 5 h_t 5 p "Text-Cell" "Table-Points" 0.0)
      )
    )
    lst_pt
    lst_id-seg
  )
  (vla-addTable Space (vlax-3d-point ins_pt_cell) (+ 2 nb) 3 (+ h_t (* h_t 0.25)) w_c)
  (setq ename_cell (vlax-ename->vla-object (entlast)) n_row (1+ nb) n_column -1)
  (vla-SetCellValue ename_cell 0 0
    (vlax-make-variant
      (strcat "Summary of " (itoa (sslength js)) " POINTS")
      8
    )
  )
  (vla-SetCellTextStyle ename_cell 0 0 "Text-Cell")
  (vla-SetCellTextHeight ename_cell 0 0 (vlax-make-variant h_t 5))
  (vla-SetCellAlignment ename_cell 0 0 5)
  (foreach n
    (mapcar'list
      (append lst_id-seg '("N°"))
      (append (mapcar 'rtos (mapcar 'car lst_pt)) '("Coordinates X"))
      (append (mapcar 'rtos (mapcar 'cadr lst_pt)) '("Coordinates Y"))
    )
    (mapcar
      '(lambda (el)
        (vla-SetCellValue ename_cell n_row (setq n_column (1+ n_column))
          (if (or (eq (rtos 0.0) el) (eq (angtos 0.0) el)) (vlax-make-variant "_" 8) (vlax-make-variant el 8))
        )
        (vla-SetCellTextStyle ename_cell n_row n_column "Text-Cell")
        (vla-SetCellTextHeight ename_cell n_row n_column (vlax-make-variant h_t 5))
        (if (eq n_row 1)
          (vla-SetCellAlignment ename_cell n_row n_column 5)
          (vla-SetCellAlignment ename_cell n_row n_column 6)
        )
      )
      n
    )
    (setq n_row (1- n_row) n_column -1)
  )
  (setvar "dimzin" oldim) (setvar "clayer" oldlay)
  (prin1)
)

chan230984 · ‎05-19-2019

@CADaSchtroumpf

Hi, It's not 1 2 3 but it's A B C

Sea-Haven · ‎05-20-2019

Where the code does a inc number you do the same but must use (chr x) the x is the key value for "A" etc please note you are limited to 26 characters.

(setq x 65)
(repeat 5
(alert (strcat (rtos x 2 0) "  =  " (chr x)))
(setq x (+ x 1))
)

chan230984 · ‎05-20-2019

@Sea-Haven

how do, I have no knowledge In this program

please write

Sea-Haven · ‎05-20-2019

It would be best for the other code poster to add to his/her code.

CADaSchtroumpf · ‎05-21-2019

Adapted to your exemple.

(vl-load-com)
(defun inc_txt (Txt / Boucle Decalage Val_Txt)
	(setq Boucle 1 Val_txt "")
	(while (<= Boucle (strlen Txt))
		(setq Ascii_Txt (vl-string-elt Txt (- (strlen Txt) Boucle)))
		(if (not Decalage)
			(setq Ascii_Txt (1+ Ascii_Txt))
		)
		(if (or (= Ascii_Txt 58) (= Ascii_Txt 91) (= Ascii_Txt 123))
			(setq
				Ascii_Txt 
					(cond
						((= Ascii_Txt 58) 48)
						((= Ascii_Txt 91) 65)
						((= Ascii_Txt 123) 97)
					)
				Decalage nil
			)
			(setq Decalage T)
		)
		(setq Val_Txt (strcat (chr Ascii_Txt) Val_Txt))
		(setq Boucle (1+ Boucle))
	)
	(if (not Decalage)
		(setq Val_Txt (strcat (cond ((< Ascii_Txt 58) "0") ((< Ascii_Txt 91) "A") ((< Ascii_Txt 123) "a")) Val_Txt))
	)
	Val_Txt
)
(defun c:points2cell ( / js AcDoc Space acmCol nw_style oldim oldlay ins_pt_cell h_t w_c lst_id-seg lst_pt n
												 obj dxf_10 nb n_ini n_next nw_obj ename_cell n_row n_column)
	(princ "\nSelect points.")
	(while (null (setq js (ssget '((0 . "POINT")))))
		(princ "\nSelection empty, or is not a point!")
	)
	(setq
		AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
		Space
		(if (= 1 (getvar "CVPORT"))
			(vla-get-PaperSpace AcDoc)
			(vla-get-ModelSpace AcDoc)
		)
		acmCol
		(vla-getinterfaceobject
			(vlax-get-acad-object)
			(strcat
				"AutoCAD.AcCmColor."
				(substr (getvar "ACADVER") 1 2)
			)
		)
	)
	(cond
		((null (tblsearch "LAYER" "XFG"))
			(vlax-put (vla-add (vla-get-layers AcDoc) "XFG") 'Color 1)
		)
	)
	(cond
		((null (tblsearch "STYLE" "TAHOMA"))
			(setq nw_style (vla-add (vla-get-textstyles AcDoc) "TAHOMA"))
			(mapcar
				'(lambda (pr val)
					(vlax-put nw_style pr val)
				)
				(list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
				(list (strcat (getenv "windir") "\\fonts\\Tahoma.ttf") 0.0 0.0 1.0 0.0)
			)
			(command "_.ddunits"
				(while (not (zerop (getvar "cmdactive")))
					(command pause)
				)
			)
		)
	)
	(setq
		oldim (getvar "dimzin")
		oldlay (getvar "clayer")
	)
	(setvar "dimzin" 0) (setvar "clayer" "XFG")
	(initget 9)
	(setq ins_pt_cell (getpoint "\nLeft-Up insert point of table: "))
	(initget 6)
	(setq h_t (getdist ins_pt_cell (strcat "\nHigth text <" (rtos (getvar "textsize")) ">: ")))
	(if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t))
	(initget 7)
	(setq w_c (getdist ins_pt_cell "\nWidth of cells: "))
	(setq
		lst_id-seg '()
		lst_pt '()
		nb 0
		n_ini "@"
		n_next n_ini
	)
	(repeat (setq n (sslength js))
		(setq
			obj (ssname js (setq n (1- n)))
			dxf_10 (cdr (assoc 10 (entget obj)))
			lst_pt (cons dxf_10 lst_pt)
			nb (1+ nb)
			n_ini n_next
			lst_id-seg (cons (setq n_next (inc_txt n_ini)) lst_id-seg)
		)
	)
	(mapcar
		'(lambda (p tx)
			(setq nw_obj
				(vla-addMtext Space
					(vlax-3d-point p)
					0.0
					tx
				)
			)
			(mapcar
				'(lambda (pr val)
					(vlax-put nw_obj pr val)
				)
				(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'color)
				(list 5 h_t 5 p "TAHOMA" "XFG" 0.0 4)
			)
		)
		lst_pt
		lst_id-seg
	)
	(vla-addTable Space (vlax-3d-point ins_pt_cell) (+ 2 nb) 3 (+ h_t (* h_t 0.25)) w_c)
	(setq ename_cell (vlax-ename->vla-object (entlast)) n_row (1+ nb) n_column -1)
	(vla-setrgb acmCol 0 255 255)
	(vla-SetCellValue ename_cell 0 0
		(vlax-make-variant
			"TABLE OF COORDINATES"
			8
		)
	)
	(vla-SetCellTextStyle ename_cell 0 0 "TAHOMA")
	(vla-SetCellTextHeight ename_cell 0 0 (vlax-make-variant h_t 5))
	(vla-SetCellAlignment ename_cell 0 0 5)
	(vla-SetCellContentColor ename_cell 0 0 acmCol)
	(foreach n
		(mapcar'list
			(append lst_id-seg '("MARK"))
			(append (mapcar 'rtos (mapcar 'cadr lst_pt)) '("NORTHING"))
			(append (mapcar 'rtos (mapcar 'car lst_pt)) '("EASTING"))
		)
		(mapcar
			'(lambda (el)
				(vla-SetCellValue ename_cell n_row (setq n_column (1+ n_column))
					(if (or (eq (rtos 0.0) el) (eq (angtos 0.0) el)) (vlax-make-variant "_" 8) (vlax-make-variant el 8))
				)
				(vla-SetCellTextStyle ename_cell n_row n_column "TAHOMA")
				(vla-SetCellTextHeight ename_cell n_row n_column (vlax-make-variant h_t 5))
				(if (eq n_row 1)
					(vla-SetCellAlignment ename_cell n_row n_column 5)
					(progn
						(vla-SetCellAlignment ename_cell n_row n_column 6)
						(vla-SetCellContentColor ename_cell n_row n_column acmCol)
					)
				)
			)
			n
		)
		(setq n_row (1- n_row) n_column -1)
	)
	(setvar "dimzin" oldim) (setvar "clayer" oldlay)
	(prin1)
)

chan230984 · ‎05-21-2019

@CADaSchtroumpf

that's right

But I would like to disturb a little more.

I want the numbers to be in the middle Center

Please help me

devitg · ‎05-21-2019

Please apologize me , I don't find any points at samples.dwg'

Would you clear me??

Thanks in advance.

chan230984 · ‎05-21-2019

@devitg

Sorry, I'm not good at English.

devitg · ‎05-21-2019

I mean : there is no points at your dwg . It are Lines and circles

What is your idiom??

devitg · ‎05-21-2019

NO

จุด

Cud

chan230984 · ‎05-21-2019

@devitg

At that point, I will create later.

Can put a circle or not

Is that I want the coordinate , table And the symbol A B C

CADaSchtroumpf · ‎05-21-2019

Find and replace

(vla-SetCellAlignment ename_cell n_row n_column 6)

by

(vla-SetCellAlignment ename_cell n_row n_column 5)

devitg · ‎05-21-2019

Ok . Understood it.

Please help me write LISP

Please help me write LISP

Forums Links

Post to forums