Now is this the updated lisp!!!
(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 dlt 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 "" (if (> id_vp 2) ""))
(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-put-color hatch 8)
(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) "E " (convert_str2mil (rtos (car el) 2 0)) (chr 160))
ori_txt (* pi 0.5)
dlt (polar el pi htx)
)
)
((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) "N " (convert_str2mil (rtos (cadr el) 2 0)) (chr 160))
ori_txt 0.0
dlt (polar el (* pi 0.5) htx)
)
)
(T (setq str nil ori_txt nil))
)
(cond
((and dlt str ori_txt)
(setq nw_txt (vla-AddMText Space (vlax-3d-point dlt) (* 1.25 htx) str))
(vla-put-layer nw_txt "A-Grilla")
(vla-put-StyleName nw_txt "A-Romans")
(vla-put-AttachmentPoint nw_txt 7)
(vla-put-InsertionPoint nw_txt (vlax-3d-point (vlax-curve-getClosestPointTo nw_pl dlt 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 9)
(vla-put-InsertionPoint nw_txt (vlax-3d-point (vlax-curve-getClosestPointTo nw_pl dlt T)))
(vla-put-TextString nw_txt (strcat str "."))
)
)
(entmod (subst '(45 . 1) (assoc 45 (entget (entlast))) (entget (entlast))))
)
)
)
(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)
)
"Save Energy"
Did you find this reply helpful? If so please use the Accept as Solution