Lisp coordinate grid - from viewport

[Edwin.Saez]

hi,

someone could help me with some routine to generate a coordinate grid by selecting a "viewport" and that the grid is drawn in the model space.

[CADaSchtroumpf]

Hi,

I have making this for meter (initially for French Lambert)

Try it, and adjust it if unit is other.

(vl-load-com)
(defun l-coor2l-pt (lst flag / )
 (if lst
 (cons (list (car lst) (cadr lst) (if flag (caddr lst) 0.0))
 (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
 )
 )
)
(defun c:ViewPort2Grid ( / js n pt_v l h lst_pt js_obj nw_pl unit_draw AcDoc Space UCS save_ucs WSC nw_style f_pat ob_lst_pt pt_ins format_scale ech hrtx nw_pl_out nw_pl_in hatch_out hatch lst_pt str ori_txt nw_txtpt_ins)
 (prin1 "\nSelect a viewport: ")
 (while
 (null
 (setq js
 (ssget "_+.:E:S:L"
 (list
 '(0 . "VIEWPORT")
 '(67 . 1)
 (cons 410 (getvar "CTAB"))
 '(-4 . "!=")
 '(69 . 1)
 )
 )
 )
 )
 )
 (setq
 pt_v (cdr (assoc 10 (setq dxf_ent (entget (setq ent (ssname js 0))))))
 l (cdr (assoc 40 dxf_ent))
 h (cdr (assoc 41 dxf_ent))
 lst_pt
 (list
 (list (- (car pt_v) (* 0.5 l)) (- (cadr pt_v) (* 0.5 h)) 0.0)
 (list (+ (car pt_v) (* 0.5 l)) (- (cadr pt_v) (* 0.5 h)) 0.0)
 (list (+ (car pt_v) (* 0.5 l)) (+ (cadr pt_v) (* 0.5 h)) 0.0)
 (list (- (car pt_v) (* 0.5 l)) (+ (cadr pt_v) (* 0.5 h)) 0.0)
 )
 js_obj (ssadd)
 )
 (vlax-get (vlax-ename->vla-object ent) 'CustomScale)
 (entmakex
 (vl-list*
 (cons 0 "LWPOLYLINE")
 (cons 100 "AcDbEntity")
 (cons 67 1)
 (cons 100 "AcDbPolyline")
 (cons 90 (length lst_pt))
 (cons 70 1)
 (mapcar '(lambda (p) (cons 10 p)) lst_pt)
 )
 )
 (ssadd (setq nw_pl (entlast)) js_obj)
 (command "_.CHSPACE" js_obj "")
 (setq unit_draw 1000)
 (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (vla-StartUndoMark AcDoc)
 (setq
 Space
 (if (eq (getvar "CVPORT") 1)
 (vla-get-PaperSpace AcDoc)
 (vla-get-ModelSpace AcDoc)
 )
 UCS (vla-get-UserCoordinateSystems AcDoc)
 save_ucs
 (vla-add UCS
 (vlax-3d-point '(0.0 0.0 0.0))
 (vlax-3d-point (getvar "UCSXDIR"))
 (vlax-3d-point (getvar "UCSYDIR"))
 "CURRENT_UCS"
 )
 )
 (vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG")))
 (setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS"))
 (vla-put-activeUCS AcDoc WCS)
 (if (not (tblsearch "STYLE" "$GRID"))
 (progn
 (setq nw_style (vla-add (vla-get-textstyles AcDoc) "$GRID"))
 (mapcar
 '(lambda (pr val)
 (vlax-put nw_style pr val)
 )
 (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
 (list "SIMPLEX.SHX" 0.0 0.0 1.0 0.0)
 )
 )
 )
 (if (not (tblsearch "LAYER" "GRID"))
 (vlax-put (vla-add (vla-get-layers AcDoc) "GRID") 'color 7)
 )
 (if (not (findfile "QUADISO.pat"))
 (progn
 (setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\QUADISO.pat") "w"))
 (write-line "*QUADISO,Quadrillage lambert" f_pat)
 (write-line "0, -.015,0, 0,1, .03,-.97" f_pat)
 (write-line "90, 0,-.015, 0,1, .03,-.97" f_pat)
 (close f_pat)
 )
 )
 (if (not (findfile "REPQUADISO.pat"))
 (progn
 (setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\REPQUADISO.pat") "w"))
 (write-line "*REPQUADISO,Repere du quadrillage lambert" f_pat)
 (write-line "0, 0,0, 0,1" f_pat)
 (write-line "90, 0,0, 0,1" f_pat)
 (close f_pat)
 )
 )
 (setq
 nw_pl (vlax-ename->vla-object nw_pl)
 ob_lst_pt (vlax-get nw_pl 'coordinates)
 pt_ins (list (car ob_lst_pt) (cadr ob_lst_pt))
 format_scale (/ 1.0 (vlax-get (vlax-ename->vla-object ent) 'CustomScale))
 ech (* unit_draw format_scale)
 htx (/ ech 500.0)
 )
 (vla-put-layer nw_pl "GRID")
 (vla-Offset nw_pl (* htx 2.5))
 (setq nw_pl_out (vlax-ename->vla-object (entlast)))
 (vla-Offset nw_pl (+ (* htx 2.5) (* htx 10.0)))
 (setq nw_pl_in (vlax-ename->vla-object (entlast)))
 (setvar "HPORIGINMODE" 0)
 (setvar "HPORIGIN" '(0.0 0.0))
 (setq hatch_out (vla-AddHatch Space acHatchPatternTypeCustomDefined "REPQUADISO" :vlax-True))
 (vlax-invoke hatch_out 'AppendOuterLoop (list nw_pl))
 (vlax-invoke hatch_out 'AppendInnerLoop (list nw_pl_out))
 (vla-put-patternscale hatch_out (/ ech 10.0))
 (vla-put-patternangle hatch_out 0.0)
 (vla-put-layer hatch_out "GRID")
 (vla-evaluate hatch_out)
 (setq hatch (vla-AddHatch Space acHatchPatternTypeCustomDefined "QUADISO" :vlax-True))
 (vlax-invoke hatch 'AppendOuterLoop (list nw_pl_in))
 (vla-put-patternscale hatch (/ ech 10.0))
 (vla-put-patternangle hatch 0.0)
 (vla-put-layer hatch "GRID")
 (vla-evaluate hatch)
 (setq lst_pt
 (l-coor2l-pt
 (vlax-invoke
 hatch_out
 'IntersectWith
 nw_pl_out
 acExtendThisEntity
 )
 T
 )
 )
 (foreach el lst_pt
 (cond
 ((or (equal (rem (car el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (car el) (/ ech 10.0)) 0.0 1E-8))
 (setq str (strcat " " (rtos (car el) 2 0) " ") ori_txt (* pi 0.5))
 )
 ((or (equal (rem (cadr el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (cadr el) (/ ech 10.0)) 0.0 1E-8))
 (setq str (strcat " " (rtos (cadr el) 2 0) " ") ori_txt 0.0)
 )
 (T (setq str nil ori_txt nil))
 )
 (cond
 ((and el str ori_txt)
 (setq nw_txt (vla-AddText Space str (vlax-3d-point el) htx))
 (vla-put-layer nw_txt "GRID")
 (vla-put-StyleName nw_txt "$GRID")
 (vla-put-Alignment nw_txt acAlignmentMiddleLeft)
 (vla-put-Rotation nw_txt ori_txt)
 (vla-put-TextAlignmentPoint nw_txt (vlax-3d-point el))
 (if (vlax-invoke nw_pl 'IntersectWith nw_txt acExtendThisEntity)
 (vla-put-Alignment nw_txt acAlignmentMiddleRight)
 )
 )
 )
 )
 (setq pt_ins (polar pt_ins (+ (* pi 0.25) (angle (list (car ob_lst_pt) (cadr ob_lst_pt)) (list (caddr ob_lst_pt) (cadddr ob_lst_pt)))) (* htx 10)))
 (setq nw_txt (vla-AddText Space (strcat " Scale 1/" (rtos ech 2 0)) (vlax-3d-point pt_ins) (* 2 htx)))
 (vla-put-layer nw_txt "GRID")
 (vla-put-StyleName nw_txt "$GRID")
 (vla-put-Alignment nw_txt acAlignmentMiddleLeft)
 (vla-put-Rotation nw_txt (angle (list (car ob_lst_pt) (cadr ob_lst_pt)) (list (caddr ob_lst_pt) (cadddr ob_lst_pt))))
 (vla-put-TextAlignmentPoint nw_txt (vlax-3d-point pt_ins))
 (and save_ucs (vla-put-activeUCS AcDoc save_ucs))
 (and WCS (vla-delete WCS) (setq WCS nil))
 (vla-EndUndoMark AcDoc)
 (prin1)
)

[Edwin.Saez]

@CADaSchtroumpf

I greatly appreciate it if you could modify the code 

1- instead of having a hatch, they can draw lines
2- texts coordinates are drawn in the drawing area
3- to configure the style and size of text
4- to configure the layer lines and texts

Thank you

[Edwin.Saez]

@Kent1Cooper,

could you help me? 

[CADaSchtroumpf]

New!

(vl-load-com)
(defun l-coor2l-pt (lst flag / )
	(if lst
		(cons (list (car lst) (cadr lst) (if flag (caddr lst) 0.0))
			(l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
		)
	)
)
(defun c:ViewPort2Grid ( / js n pt_v l h lst_pt js_obj nw_pl unit_draw AcDoc Space UCS save_ucs WSC nw_style f_pat ob_lst_pt pt_ins format_scale ech hrtx nw_pl_out hatch lst_pt str ori_txt nw_txtpt_ins)
	(prin1 "\nSelect a viewport: ")
	(while
		(null
			(setq js
				(ssget "_+.:E:S:L"
					(list
						'(0 . "VIEWPORT")
						'(67 . 1)
						(cons 410 (getvar "CTAB"))
						'(-4 . "!=")
						'(69 . 1)
					)
				)
			)
		)
	)
	(setq
		pt_v (cdr (assoc 10 (setq dxf_ent (entget (setq ent (ssname js 0))))))
		l (cdr (assoc 40 dxf_ent))
		h (cdr (assoc 41 dxf_ent))
		lst_pt
		(list
			(list (- (car pt_v) (* 0.5 l)) (- (cadr pt_v) (* 0.5 h)) 0.0)
			(list (+ (car pt_v) (* 0.5 l)) (- (cadr pt_v) (* 0.5 h)) 0.0)
			(list (+ (car pt_v) (* 0.5 l)) (+ (cadr pt_v) (* 0.5 h)) 0.0)
			(list (- (car pt_v) (* 0.5 l)) (+ (cadr pt_v) (* 0.5 h)) 0.0)
		)
		js_obj (ssadd)
	)
	(vlax-get (vlax-ename->vla-object ent) 'CustomScale)
	(entmakex
		(vl-list*
			(cons 0 "LWPOLYLINE")
			(cons 100 "AcDbEntity")
			(cons 67 1)
			(cons 100 "AcDbPolyline")
			(cons 90 (length lst_pt))
			(cons 70 1)
			(mapcar '(lambda (p) (cons 10 p)) lst_pt)
		)
	)
	(ssadd (setq nw_pl (entlast)) js_obj)
	(command "_.CHSPACE" js_obj "")
	(setq unit_draw 1000)
	(setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
	(vla-StartUndoMark AcDoc)
	(setq
		Space
		(if (eq (getvar "CVPORT") 1)
			(vla-get-PaperSpace AcDoc)
			(vla-get-ModelSpace AcDoc)
		)
		UCS (vla-get-UserCoordinateSystems AcDoc)
		save_ucs
		(vla-add UCS
			(vlax-3d-point '(0.0 0.0 0.0))
			(vlax-3d-point (getvar "UCSXDIR"))
			(vlax-3d-point (getvar "UCSYDIR"))
			"CURRENT_UCS"
		)
	)
	(vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG")))
	(setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS"))
	(vla-put-activeUCS AcDoc WCS)
	(if (not (tblsearch "STYLE" "$GRID"))
		(progn
			(setq nw_style (vla-add (vla-get-textstyles AcDoc) "$GRID"))
			(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 0.0 1.0 0.0)
			)
		)
	)
	(if (not (tblsearch "LAYER" "GRID"))
		(vlax-put (vla-add (vla-get-layers AcDoc) "GRID") 'color 7)
	)
	(if (not (findfile "REPQUADISO.pat"))
		(progn
			(setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\REPQUADISO.pat") "w"))
			(write-line "*REPQUADISO,Repere du quadrillage lambert" f_pat)
			(write-line "0, 0,0, 0,1" f_pat)
			(write-line "90, 0,0, 0,1" f_pat)
			(close f_pat)
		)
	)
	(setq
		nw_pl (vlax-ename->vla-object nw_pl)
		ob_lst_pt (vlax-get nw_pl 'coordinates)
		pt_ins (list (car ob_lst_pt) (cadr ob_lst_pt))
		format_scale (/ 1.0 (vlax-get (vlax-ename->vla-object ent) 'CustomScale))
		ech (* unit_draw format_scale)
		htx (/ ech 500.0)
	)
	(vla-put-layer nw_pl "GRID")
	(vla-Offset nw_pl (* htx 2.5))
	(setq nw_pl_out (vlax-ename->vla-object (entlast)))
	(setvar "HPORIGINMODE" 0)
	(setvar "HPORIGIN" '(0.0 0.0))
	(setq hatch (vla-AddHatch Space acHatchPatternTypeCustomDefined "REPQUADISO" :vlax-True))
	(vlax-invoke hatch 'AppendOuterLoop (list nw_pl))
	(vla-put-patternscale hatch (/ ech 10.0))
	(vla-put-patternangle hatch 0.0)
	(vla-put-layer hatch "GRID")
	(vla-evaluate hatch)
	(setq lst_pt
		(l-coor2l-pt
			(vlax-invoke
				hatch
				'IntersectWith
				nw_pl
				acExtendThisEntity
			)
			T
		)
	)
	(foreach el lst_pt
		(cond
			((or (equal (rem (car el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (car el) (/ ech 10.0)) 0.0 1E-8))
				(setq str (strcat "E " (rtos (car el) 2 0) " ") ori_txt (* pi 0.5))
			)
			((or (equal (rem (cadr el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (cadr el) (/ ech 10.0)) 0.0 1E-8))
				(setq str (strcat "N " (rtos (cadr el) 2 0) " ") ori_txt 0.0)
			)
			(T (setq str nil ori_txt nil))
		)
		(cond
			((and el str ori_txt)
				(setq nw_txt (vla-AddText Space str (vlax-3d-point el) htx))
				(vla-put-layer nw_txt "GRID")
				(vla-put-StyleName nw_txt "$GRID")
				(vla-put-Alignment nw_txt acAlignmentBottomLeft)
				(vla-put-Rotation nw_txt ori_txt)
				(vla-put-TextAlignmentPoint nw_txt (vlax-3d-point el))
				(if (vlax-invoke nw_pl_out 'IntersectWith nw_txt acExtendThisEntity)
					(vla-put-Alignment nw_txt acAlignmentBottomRight)
				)
			)
		)
	)
	(vla-delete nw_pl_out)
	(setq pt_ins (polar pt_ins (+ (* pi 0.25) (angle (list (car ob_lst_pt) (cadr ob_lst_pt)) (list (caddr ob_lst_pt) (cadddr ob_lst_pt)))) (* htx 10)))
	(setq nw_txt (vla-AddText Space (strcat " Scale 1/" (rtos ech 2 0)) (vlax-3d-point pt_ins) (* 2 htx)))
	(vla-put-layer nw_txt "GRID")
	(vla-put-StyleName nw_txt "$GRID")
	(vla-put-Alignment nw_txt acAlignmentMiddleLeft)
	(vla-put-Rotation nw_txt (angle (list (car ob_lst_pt) (cadr ob_lst_pt)) (list (caddr ob_lst_pt) (cadddr ob_lst_pt))))
	(vla-put-TextAlignmentPoint nw_txt (vlax-3d-point pt_ins))
	(and save_ucs (vla-put-activeUCS AcDoc save_ucs))
	(and WCS (vla-delete WCS) (setq WCS nil))
	(vla-EndUndoMark AcDoc)
	(prin1)
)

For have line, you can explode hatch !

For personalize style (i take Arial font) and layer see this section in code:

(if (not (tblsearch "STYLE" "$GRID"))
(progn
(setq nw_style (vla-add (vla-get-textstyles AcDoc) "$GRID"))
(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 0.0 1.0 0.0)
)
)
)
(if (not (tblsearch "LAYER" "GRID"))
(vlax-put (vla-add (vla-get-layers AcDoc) "GRID") 'color 7)
)

If you change name, correlate the remaining code

[Edwin.Saez]

@CADaSchtroumpf,

There is an error, check that the coordinates of the lines (after exploding) do not match the actual coordinates. (attached image)
Could it be changed so that it is not a text source, but a text style that is defined as current in the drawing?

Could you define a layer for the text?

If you need to place a "NORTH" block, at the end of placing the grid?

I really appreciate your help 

[Edwin.Saez]

@CADaSchtroumpf,

Help me please I'd appreciate it a lot.. 

[CADaSchtroumpf]

There is an error, check that the coordinates of the lines (after exploding)

You must have a good scale in your viewport before using lisp.

For exemple set a zoom in viewport at 1000/5000XP for a scale at 5000 if you use meter.

Could it be changed so that it is not a text source, but a text style that is defined as current in the drawing?

You can redefine the style $GRID after, with font what you wont.

Could you define a layer for the text?

If you need to place a "NORTH" block, at the end of placing the grid?

See new code for this

[Edwin.Saez]

@CADaSchtroumpf,

It works well,
Could you tell me where I can change the text size of the coordinates?
If I want another form of north ?, how could I do?
thank you very much for your help! 

[Edwin.Saez]

@CADaSchtroumpf,

Doing tests, I found some errors,
When the working area is located at coordinates, for example: E = 845 321, N = 8 642 351, does not place the texts of the coordinates.
Also when the view is rotated, does not place the texts
thanks for helping 

[CADaSchtroumpf]

Give a dwg exemple (not image) where you found errors.

And also have content your bloc North and your fonts that you want use in your dwg.

[Edwin.Saez]

@CADaSchtroumpf,

Could you consider the following characteristics? I will thank you very much!

- with the same text style (text with mask 1)
- the same layers and colors
- I put the North Block

With lisp, the text is always in size 2, from the viewport, it could be 2.5?
Attached dwg.

thanks for your help 

[CADaSchtroumpf]

OK, Try with this!

Please, if the block A-NORTE exist, erase it and purge the drawing  before use lisp.

[Edwin.Saez]

@CADaSchtroumpf,

thanks for answering,
So as not to abuse your time and help, you could tell me which part of the code I can change to adjust the text that goes outside the limit.
Also to change the text format of:
- E 325500 to E 325 500
- N 8596400 to N 8 596 400
I also want to set the text mask to 1

With this would be perfect for me.

Thank you very much, your help. You are a great collaborator.

[CADaSchtroumpf]

I have try to adjust code for a best presentation.

I also want to set the text mask to 1.

The mask is present, command REGENALL can be necessary at end of code.

Spoiler

(vl-load-com)
(defun l-coor2l-pt (lst flag / )
		(if lst
				(cons (list (car lst) (cadr lst) (if flag (caddr lst) 0.0))
						(l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
				)
		)
)
(defun convert_str2mil (str2cnv / l_str n l_nw)
	(setq l_str (reverse (vl-string->list str2cnv)) n 1)
	(while l_str
		(if (zerop (rem n 3))
			(setq l_nw (cons 32 (cons (car l_str) l_nw)))
			(setq l_nw (cons (car l_str) l_nw))
		)
		(setq l_str (cdr l_str) n (1+ n))
	)
	(vl-list->string l_nw)
)
(defun c:ViewPort2Grid ( / js ent dxf_ent pt_v id_vp l h lst_pt js_obj nw_pl unit_draw AcDoc Space UCS save_ucs WSC nw_style f_pat ob_lst_pt pt_ins format_scale ech htx nw_pl_out hatch lst_pt str ori_txt nw_txt pt_ins)
	(setvar "CMDECHO" 0)
	(if (eq (getvar "CTAB") "Model") (setvar "TILEMODE" 0))
	(command "_.PSPACE")
	(princ "\nSelect a viewport: ")
	(while
		(null
			(setq js
				(ssget "_+.:E:S:L"
					(list
						'(0 . "VIEWPORT")
						'(67 . 1)
						(cons 410 (getvar "CTAB"))
						'(-4 . "!=")
						'(69 . 1)
					)
				)
			)
		)
	)
	(setq
		pt_v (cdr (assoc 10 (setq dxf_ent (entget (setq ent (ssname js 0))))))
		id_vp (cdr (assoc 69 dxf_ent))
		l (cdr (assoc 40 dxf_ent))
		h (cdr (assoc 41 dxf_ent))
		lst_pt
		(list
			(list (- (car pt_v) (* 0.5 l)) (- (cadr pt_v) (* 0.5 h)) 0.0)
			(list (+ (car pt_v) (* 0.5 l)) (- (cadr pt_v) (* 0.5 h)) 0.0)
			(list (+ (car pt_v) (* 0.5 l)) (+ (cadr pt_v) (* 0.5 h)) 0.0)
			(list (- (car pt_v) (* 0.5 l)) (+ (cadr pt_v) (* 0.5 h)) 0.0)
		)
		js_obj (ssadd)
	)
	(entmakex
		(vl-list*
			(cons 0 "LWPOLYLINE")
			(cons 100 "AcDbEntity")
			(cons 67 1)
			(cons 100 "AcDbPolyline")
			(cons 90 (length lst_pt))
			(cons 70 1)
			(mapcar '(lambda (p) (cons 10 p)) lst_pt)
		)
	)
	(ssadd (setq nw_pl (entlast)) js_obj)
	(command "_.MSPACE")
	(setvar "CVPORT" id_vp)
	(command "_.PSPACE")
	(command "_.CHSPACE" js_obj "" "")
	(command "_.MSPACE")
	(setq unit_draw 1000)
	(setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
	(vla-StartUndoMark AcDoc)
	(setq
		Space
		(if (eq (getvar "CVPORT") 1)
			(vla-get-PaperSpace AcDoc)
			(vla-get-ModelSpace AcDoc)
		)
		UCS (vla-get-UserCoordinateSystems AcDoc)
		save_ucs
		(vla-add UCS
			(vlax-3d-point '(0.0 0.0 0.0))
			(vlax-3d-point (getvar "UCSXDIR"))
			(vlax-3d-point (getvar "UCSYDIR"))
			"CURRENT_UCS"
		)
	)
	(vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG")))
	(setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS"))
	(vla-put-activeUCS AcDoc WCS)
	(if (not (tblsearch "STYLE" "A-Romans"))
		(progn
			(setq nw_style (vla-add (vla-get-textstyles AcDoc) "A-Romans"))
			(mapcar
				'(lambda (pr val)
					(vlax-put nw_style pr val)
				)
				(list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
				(list "ROMANS.SHX" 0.0 0.0 0.8 0.0)
			)
		)
	)
	(if (not (tblsearch "LAYER" "A-Grilla"))
		(vlax-put (vla-add (vla-get-layers AcDoc) "A-Grilla") 'color 7)
	)
	(if (not (findfile "REPQUADISO.pat"))
		(progn
			(setq f_pat (open (strcat (getvar "ROAMABLEROOTPREFIX") "support\\REPQUADISO.pat") "w"))
			(write-line "*REPQUADISO,Repere du quadrillage lambert" f_pat)
			(write-line "0, 0,0, 0,1" f_pat)
			(write-line "90, 0,0, 0,1" f_pat)
			(close f_pat)
		)
	)
	(if (not (tblsearch "BLOCK" "A-NORTE"))
		(foreach n
			'(
				(
					(0 . "BLOCK")
					(8 . "0")
					(2 . "A-NORTE")
					(70 . 0)
					(8 . "0")
					(62 . 0)
					(6 . "ByBlock")
					(370 . -2)
					(10 0.0 0.0 0.0)
				)
				(
					(0 . "LWPOLYLINE")
					(100 . "AcDbEntity")
					(67 . 0)
					(410 . "Model")
					(8 . "0")
					(62 . 0)
					(6 . "ByBlock")
					(370 . -2)
					(100 . "AcDbPolyline")
					(90 . 13)
					(70 . 1)
					(38 . 0.0)
					(39 . 0.0)
					(10 0.00625 -0.001)
					(40 . 0.0025)
					(41 . 0.0025)
					(42 . 0.0)
					(91 . 0)
					(10 0.0045 -0.001)
					(40 . 0.00125655)
					(41 . 0.00125655)
					(42 . 0.0)
					(91 . 0)
					(10 0.00112828 0.00479937)
					(40 . 0.00130141)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 0.0005 0.00713)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 0.0005 0.00125)
					(40 . 0.0025)
					(41 . 0.0025)
					(42 . 0.0)
					(91 . 0)
					(10 -0.0005 0.00125)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -0.0005 0.00713)
					(40 . 0.0)
					(41 . 0.00130141)
					(42 . 0.0)
					(91 . 0)
					(10 -0.00112828 0.00479937)
					(40 . 0.00125655)
					(41 . 0.00125655)
					(42 . 0.0)
					(91 . 0)
					(10 -0.0045 -0.001)
					(40 . 0.0025)
					(41 . 0.0025)
					(42 . 0.0)
					(91 . 0)
					(10 -0.00625 -0.001)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -0.00625 0.00025)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -1.20856e-013 0.011)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 0.00625 0.00025)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(210 0.0 0.0 1.0)
				)
				(
					(0 . "LWPOLYLINE")
					(100 . "AcDbEntity")
					(67 . 0)
					(410 . "Model")
					(8 . "0")
					(62 . 0)
					(6 . "ByBlock")
					(370 . -2)
					(100 . "AcDbPolyline")
					(90 . 11)
					(70 . 1)
					(38 . 0.0)
					(39 . 0.0)
					(10 0.0025 -0.008875)
					(40 . 0.00225)
					(41 . 0.00225)
					(42 . 0.0)
					(91 . 0)
					(10 0.00125 -0.008875)
					(40 . 0.00137185)
					(41 . 0.00137185)
					(42 . 0.0)
					(91 . 0)
					(10 -0.000564075 -0.0065167)
					(40 . 0.00144903)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -0.00125 -0.0045)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -0.00125 -0.008875)
					(40 . 0.00225)
					(41 . 0.00225)
					(42 . 0.0)
					(91 . 0)
					(10 -0.0025 -0.008875)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -0.0025 -0.00225)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 -0.00125 -0.00225)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 0.00125 -0.0055)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 0.00125 -0.00225)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(10 0.0025 -0.00225)
					(40 . 0.0)
					(41 . 0.0)
					(42 . 0.0)
					(91 . 0)
					(210 0.0 0.0 1.0)
				)
				(
					(0 . "ENDBLK")
					(8 . "0")
					(62 . 0)
					(6 . "ByBlock")
					(370 . -2)
				)
			)
			(entmake n)
		)
	)
	(setq
		nw_pl (vlax-ename->vla-object nw_pl)
		ob_lst_pt (vlax-get nw_pl 'coordinates)
		pt_ins (list (car ob_lst_pt) (cadr ob_lst_pt))
		format_scale (/ 1.0 (vlax-get (vlax-ename->vla-object ent) 'CustomScale))
		ech (* unit_draw format_scale)
		htx (/ ech 500.0)
	)
	(vla-put-layer nw_pl "A-Grilla")
	(vla-Offset nw_pl (* htx 2.5))
	(setq nw_pl_out (vlax-ename->vla-object (entlast)))
	(setvar "HPORIGINMODE" 0)
	(setvar "HPORIGIN" '(0.0 0.0))
	(setq hatch (vla-AddHatch Space acHatchPatternTypeCustomDefined "REPQUADISO" :vlax-True))
	(vlax-invoke hatch 'AppendOuterLoop (list nw_pl))
	(vla-put-patternscale hatch (/ ech 10.0))
	(vla-put-patternangle hatch 0.0)
	(vla-put-layer hatch "A-Grilla")
	(vla-evaluate hatch)
	(setq lst_pt
		(l-coor2l-pt
			(vlax-invoke
				hatch
				'IntersectWith
				nw_pl
				acExtendThisEntity
			)
			T
		)
	)
	(foreach el lst_pt
		(cond
			((or (equal (rem (car el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (car el) (/ ech 10.0)) 0.0 1E-8))
				(setq str (strcat "-" (chr 160) (chr 160) "E " (convert_str2mil (rtos (car el) 2 0)) (chr 160) (chr 160) "-") ori_txt (* pi 0.5))
			)
			((or (equal (rem (cadr el) (/ ech 10.0)) (/ ech 10.0) 1E-8) (equal (rem (cadr el) (/ ech 10.0)) 0.0 1E-8))
				(setq str (strcat "-" (chr 160) (chr 160) "N " (convert_str2mil (rtos (cadr el) 2 0)) (chr 160) (chr 160) "-") ori_txt 0.0)
			)
			(T (setq str nil ori_txt nil))
		)
		(cond
			((and el str ori_txt)
				(setq nw_txt (vla-AddMText Space (vlax-3d-point el) (* 1.25 htx) str))
				(vla-put-layer nw_txt "A-Grilla")
				(vla-put-StyleName nw_txt "A-Romans")
				(vla-put-AttachmentPoint nw_txt 4)
				(vla-put-InsertionPoint nw_txt (vlax-3d-point (vlax-curve-getClosestPointTo nw_pl el T)))
				(vla-put-Rotation nw_txt ori_txt)
				(vla-put-Height nw_txt (* 1.25 htx))
				(vla-put-Width nw_txt 0.0)
				(vla-put-BackgroundFill nw_txt -1)
				(if (> (vlax-safearray-get-u-bound (vlax-variant-value (vla-IntersectWith nw_pl_out nw_txt acExtendNone)) 1) 0)
					(progn
						(vla-put-AttachmentPoint nw_txt 6)
						(vla-put-InsertionPoint nw_txt (vlax-3d-point (vlax-curve-getClosestPointTo nw_pl el T)))
					)
				)
			)
		)
	)
	(vla-delete nw_pl_out)
	(setq pt_ins (polar pt_ins (+ (* pi 0.25) (angle (list (car ob_lst_pt) (cadr ob_lst_pt)) (list (caddr ob_lst_pt) (cadddr ob_lst_pt)))) (* htx 10)))
	(setq nw_txt (vla-AddText Space (strcat " Scale 1/" (rtos ech 2 0)) (vlax-3d-point pt_ins) (* 2 htx)))
	(vla-put-layer nw_txt "A-Grilla")
	(vla-put-StyleName nw_txt "A-Romans")
	(vla-put-Alignment nw_txt acAlignmentMiddleLeft)
	(vla-put-Rotation nw_txt (angle (list (car ob_lst_pt) (cadr ob_lst_pt)) (list (caddr ob_lst_pt) (cadddr ob_lst_pt))))
	(vla-put-TextAlignmentPoint nw_txt (vlax-3d-point pt_ins))
	(initget 9)
	(setq pt_ins (getpoint "\nGive insertion point of North: "))
	(entmakex
		(vl-list*
			(cons 0 "INSERT")
			(cons 100 "AcDbEntity")
			(cons 67 0)
			(cons 410 "Model")
			(cons 8 "GRID")
			(cons 100 "AcDbBlockReference")
			(cons 2 "A-NORTE")
			(cons 10 pt_ins)
			(cons 41 ech)
			(cons 42 ech)
			(cons 43 ech)
			(cons 50 0.0)
			(cons 70 0)
			(cons 71 0)
			(cons 44 0.0)
			(cons 45 0.0)
			(list (cons 210 (list 0.0 0.0 1.0)))
		)
	)
	(vl-list*
		(cons 0 "INSERT")
		(cons 100 "AcDbEntity")(cons 210 (list 0.0 0.0 1.0))
	)
	(and save_ucs (vla-put-activeUCS AcDoc save_ucs))
	(and WCS (vla-delete WCS) (setq WCS nil))
	(command "_.PSPACE")
	(vla-EndUndoMark AcDoc)
	(setvar "CMDECHO" 1)
	(prin1)
)

[john.uhden]

To achieve that formatting with the spaces you might need a helpful function.

This used to be called "rtoc" which means "real to comma" but it's easy to have it use other delimiters.

I'll call it "delimreal."

;;----------------------------------------------------
;; This function pads a numeric string with a delimiter
;; Revised to handle negative values (03-14-02)
;; Re-written (11-20-04)
;; Changed to allow any string delimiter (11-15-16)
;; Arguments:
;;  N = any real number, positive or negative
;;  Delim = any string to separate the numbers into groups of 3.
;;  Prec = desired precision (after the decimal)
(defun delimreal (N Delim Prec / Sign Str i j)
  (setq Prec (max 0 Prec)
        Sign (if (minusp N) "-" "")
        Str  (rtos (abs N) 2 Prec)
        i    (vl-string-search Delim Str)
  )
  (if (not i)(setq i (strlen Str)))
  (setq j i)
  (if (zerop (setq i (rem i 3)))(setq i 3))
  (while (< i j)
    (setq Str (strcat (substr Str 1 i) Delim (substr Str (1+ i)))
          i (+ i 4)
          j (1+ j)
    )
  )
  (strcat Sign Str)
)

I didn't test it with the Delim argument, but I think it will work just fine.
I'm sure that others here could streamline it, but I have always sort of plodded
through my code so that there could be a chance of understanding it as my age increases.

[CADaSchtroumpf]

Hi john,

Idea is good, but i think that i have proposed is better, test différence with different precision

(defun delimreal (N Delim Prec / Sign Str i j)
  (setq Prec (max 0 Prec)
        Sign (if (minusp N) "-" "")
        Str  (rtos (abs N) 2 Prec)
        i    (vl-string-search Delim Str)
  )
  (if (not i)(setq i (strlen Str)))
  (setq j i)
  (if (zerop (setq i (rem i 3)))(setq i 3))
  (while (< i j)
    (setq Str (strcat (substr Str 1 i) Delim (substr Str (1+ i)))
          i (+ i 4)
          j (1+ j)
    )
  )
  (strcat Sign Str)
)
(defun convert_str2mil (str2cnv flag / l_str n l_nw)
  (if flag
    (setq l_str (vl-string->list str2cnv) n 1)
    (setq l_str (reverse (vl-string->list str2cnv)) n 1)
  )
  (while l_str
    (if (zerop (rem n 3))
      (setq l_nw (cons 160 (cons (car l_str) l_nw)))
      (setq l_nw (cons (car l_str) l_nw))
    )
    (setq l_str (cdr l_str) n (1+ n))
  )
  (if flag
    (vl-list->string (reverse l_nw))
    (vl-list->string l_nw)
  )
)
(defun c:test ( / prec pt x y)
  (initget 5)
  (setq prec (getint "\nPrecision: "))
  (initget 1)
  (setq pt (getpoint "\nPoint: "))
  (setq x (car pt) y (cadr pt))
  (if (zerop prec)
    (print (strcat (itoa (fix x)) "," (itoa (fix y))))
    (print (strcat (rtos x 2 prec) "," (rtos y 2 prec)))
  )
  (princ
    (strcat "\nWith convert 2 mil \t"
      (convert_str2mil (rtos (fix x) 2 0) nil)
      (if (zerop prec) "" ".")
      (convert_str2mil (substr (rtos (- x (fix x)) 2 prec) (if (< (fix x) 0) 4 3)) T)
      ","
      (convert_str2mil (rtos (fix y) 2 0) nil)
      (if (zerop prec) "" ".")
      (convert_str2mil (substr (rtos (- y (fix y)) 2 prec) (if (< (fix y) 0) 4 3)) T)
    )
  )
  (princ
    (strcat "\nWith delim real \t\t"
      (delimreal x (chr 160) prec)
      ","
      (delimreal y (chr 160) prec)
    )
  )
  (prin1)
)

[Edwin.Saez]

@CADaSchtroumpf,

I still have the same problem of not placing the texts of the coordinates when the zone is for example:

- E 310 398 y N 8 845 602

* Perhaps, he would have the possibility of having a better presentation in the texts without having to place the gions at the ends?

* The format of separation of texts, can only be achieved with another lisp? , Could not be integrated automatically in this grid lisp?

Thanks for the help @CADaSchtroumpf, @john.uhden

[Edwin.Saez]

@CADaSchtroumpf, I would like to finish this lisp and give as a solution. 

I am attaching the lisp so that they can help me by modifying it. Also attached a dwg where it looks like it should be.

- the hatch must be in color 8 (per object)
- texts must be above the lines.

I really appreciate the help

[Edwin.Saez]

@CADaSchtroumpf, I would like to finish this lisp and give as a solution. 

I am attaching the lisp so that they can help me by modifying it. Also attached a dwg where it looks like it should be.

- the hatch must be in color 8 (per object)
- texts must be above the lines.

I really appreciate the help