@symoin
In this form it is suitable?
(vl-load-com)
(defun make_field (obj p / nw_obj)
(setq
nw_obj
(vla-addMtext Space
(vlax-3d-point p)
0.0
(strcat
"{\\fArial|b0|i0|c0|p34;"
"%<\\AcVar ctab>%"
" - Scale 1/"
"%<\\AcExpr (1000/"
"%<\\AcObjProp Object(%<\\_ObjId "
(itoa (vla-get-ObjectID (vlax-ename->vla-object obj)))
">%).CustomScale \\f \"%lu2%qf2816\">%"
") \\f \"%lu2%pr0\">%"
)
)
)
(mapcar
'(lambda (pr val)
(vlax-put nw_obj pr val)
)
(list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'BackgroundFill)
(list 7 3.5 5 p "Standard" "0" 0.0 -1)
)
)
(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 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)
(setq
AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
Space (vla-get-PaperSpace AcDoc)
)
(vla-StartUndoMark AcDoc)
(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)
)
(make_field ent (car lst_pt))
(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 "" (if (> id_vp 2) ""))
(command "_.MSPACE")
(setq unit_draw 1000)
(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 1.0)
htx 2.5
)
(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 (chr 160) (chr 160) "E " (rtos (car el) 2 0) (chr 160) (chr 160) (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 " (rtos (cadr el) 2 0) (chr 160) (chr 160) (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) htx str))
(vla-put-layer nw_txt "GRID")
(vla-put-StyleName nw_txt "$GRID")
(vla-put-AttachmentPoint nw_txt 4)
(vla-put-InsertionPoint nw_txt (vlax-3d-point (polar (vlax-curve-getClosestPointTo nw_pl el T) (+ ori_txt (* 0.25 pi)) (sqrt (* 5.0 htx)))))
(vla-put-Rotation nw_txt ori_txt)
(vla-put-Height nw_txt 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 (polar (vlax-curve-getClosestPointTo nw_pl el T) (+ ori_txt (* 0.75 pi)) (sqrt (* 5.0 htx)))))
)
)
)
)
)
(vla-delete nw_pl_out)
(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)
)
