Hi,
Try this!
(vl-load-com)
(defun des_vec (lst col / lst_sg)
(setq lst_sg (list (cadr lst) (car lst)))
(setq lst (cdr lst))
(while lst
(if (cadr lst)
(setq lst_sg (cons (cadr lst) (cons (car lst) lst_sg)))
(setq lst_sg (cons (last lst_sg) (cons (car lst) lst_sg)))
)
(setq lst (cdr lst))
)
(setq lst_sg (cons col lst_sg))
(grvecs lst_sg)
)
(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 remove_doubles (lst)
(cond
((null lst) nil)
(T
(cons (car lst) (remove_doubles (vl-remove (car lst) lst)))
)
)
)
(defun c:DIM-GRID ( / unit_draw AcDoc Space UCS save_ucs WCS dx_u hview old_snapang pt_ins dx dy pt_tmp ang l_scale format_scale coeff
key pt_key n nb_column nb_raw pt_row count s_ang nw_style f_pat nw_pl ech htx hatch lst_pt str_x ori_txt_x str_y ori_txt_y nw_txt)
(if (or (eq (getvar "USERS5") "") (not (eq (substr (getvar "USERS5") 1 2) "qz")))
(setvar "USERS5" (strcat "qz" (itoa (setq unit_draw 1000))))
(setq unit_draw (atoi (substr (getvar "USERS5") 3)))
)
(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)
(initget 6)
(setq dx_u (getreal "\nDistance in millimeter of your template iso <210.0>: "))
(if (not dx_u) (setq dx_u 210.0))
(setq
hview (getvar "VIEWSIZE")
old_snapang (getvar "SNAPANG")
pt_ins (list (- (car (getvar "VIEWCTR")) (* hview 0.5)) (- (cadr (getvar "VIEWCTR")) (* hview 0.5)))
dx dx_u dy (* dx_u (sqrt 2)) pt_tmp pt_ins ang (getvar "SNAPANG")
l_scale '(1.0 1.25 2.0 2.5 5.0 7.5)
format_scale (car l_scale)
coeff 1.0
)
(if (> (fix (/ hview dy)) 3)
(while (> (fix (/ hview dy)) 3)
(foreach value l_scale
(if (> (fix (/ hview dy)) 3)
(setq format_scale value dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
)
)
(if (> (fix (/ hview dy)) 3)
(setq
coeff (* coeff 10.0)
l_scale (mapcar '(lambda (x) (* x coeff)) l_scale)
format_scale (car l_scale)
)
)
)
)
(if (< (fix (/ hview dy)) 1)
(while (< (fix (/ hview dy)) 1)
(foreach value (reverse l_scale)
(if (< (fix (/ hview dy)) 1)
(setq format_scale value dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
)
)
(if (< (fix (/ hview dy)) 1)
(setq
coeff (* coeff 0.1)
l_scale (mapcar '(lambda (x) (* x coeff)) l_scale)
format_scale (last l_scale)
)
)
)
)
(princ (strcat "\nSpecify top rigth corner or: [P] for new Position of bottom left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
(while (and (setq key (grread T 4 0)) (/= (car key) 3))
(cond
((eq (car key) 5)
(setq pt_key (cadr key))
(setq n
(*
(setq nb_column (fix (/ (+ (* (- (car pt_key) (car pt_ins)) (cos ang)) (* (- (cadr pt_key) (cadr pt_ins)) (sin ang))) dx)))
(setq nb_raw (fix (/ (- (* (- (cadr pt_key) (cadr pt_ins)) (cos ang)) (* (- (car pt_key) (car pt_ins)) (sin ang))) dy)))
)
pt_row pt_ins count 0
)
(redraw)
(repeat n
(des_vec
(list
(list (car pt_ins) (cadr pt_ins))
(list (+ (car pt_ins) (* dx (cos ang))) (+ (cadr pt_ins) (* dx (sin ang))))
(setvar "LASTPOINT"
(list
(+ (car pt_ins) (- (* dx (cos ang)) (* dy (sin ang))))
(+ (cadr pt_ins) (+ (* dy (cos ang)) (* dx (sin ang))))
)
)
(list (- (car pt_ins) (* dy (sin ang))) (+ (cadr pt_ins) (* dy (cos ang))))
)
3
)
(setq count (1+ count))
(if (< count nb_column)
(setq pt_ins (list (+ (car pt_ins) (* dx (cos ang))) (+ (cadr pt_ins) (* dx (sin ang)))))
(setq pt_ins (list (- (car pt_row) (* dy (sin ang))) (+ (cadr pt_row) (* dy (cos ang)))) pt_row pt_ins count 0)
)
)
(setq pt_ins pt_tmp)
)
((or (eq (cadr key) 114) (eq (cadr key) 82))
(initget 0)
(setq s_ang
(getorient pt_ins
(strcat
"\nNew angle<"
(angtos (getvar "SNAPANG"))
">: "
)
)
)
(if (not s_ang) (setq s_ang ang))
(if (and (> s_ang (/ pi 2)) (<= s_ang (/ (* 3 pi) 2)))
(setq ang (+ s_ang pi))
(setq ang s_ang)
)
(setvar "SNAPANG" ang)
(princ (strcat "\nSpecify top rigth corner or: [P] for new Position of bottom left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
)
((or (eq (cadr key) 112) (eq (cadr key) 80))
(initget 9)
(setq pt_ins (getpoint "\nSpecify down left corner: "))
(setq pt_ins (list (car pt_ins) (cadr pt_ins)) pt_tmp pt_ins)
(princ (strcat "\nSpecify top rigth corner or: [P] for new Position of bottom left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
)
((eq (cadr key) 43)
(setq format_scale (cadr (member format_scale l_scale)))
(if (not format_scale) (setq format_scale (car (setq l_scale (mapcar '(lambda (x) (* x 10.0)) l_scale)))))
(setq dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
(princ (strcat "\nSpecify top rigth corner or: [P] for new Position of bottom left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
)
((eq (cadr key) 45)
(setq format_scale (cadr (member format_scale (reverse l_scale))))
(if (not format_scale) (setq format_scale (last (setq l_scale (mapcar '(lambda (x) (* x 0.1)) l_scale)))))
(setq dx (* dx_u format_scale) dy (* dx_u (sqrt 2) format_scale))
(princ (strcat "\nSpecify top rigth corner or: [P] for new Position of bottom left corner,[R] for make Rotate, [+/-] change scale <" (rtos (* unit_draw format_scale) 2 3) ">: "))
)
)
)
(princ "\n")
(redraw)
(if (not (tblsearch "STYLE" "$DIM-GRID"))
(progn
(setq nw_style (vla-add (vla-get-textstyles AcDoc) "$DIM-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" "DIM-GRID"))
(vlax-put (vla-add (vla-get-layers AcDoc) "DIM-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-invoke Space 'AddLightWeightPolyline
(append
pt_ins
(polar pt_ins (+ (getvar "SNAPANG") (* pi 0.5)) (* (distance pt_ins (getvar "LASTPOINT")) (sin (- (angle pt_ins (getvar "LASTPOINT")) (getvar "SNAPANG")))))
(list (car (getvar "LASTPOINT")) (cadr (getvar "LASTPOINT")))
(polar pt_ins (getvar "SNAPANG") (* (distance pt_ins (getvar "LASTPOINT")) (cos (- (angle pt_ins (getvar "LASTPOINT")) (getvar "SNAPANG")))))
)
)
ech (* unit_draw format_scale)
htx (/ ech 500.0)
)
(vla-put-Closed nw_pl 1)
(vla-put-layer nw_pl "DIM-GRID")
(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 "DIM-GRID")
(vla-evaluate hatch)
(setq lst_pt
(l-coor2l-pt
(vlax-invoke
hatch
'IntersectWith
hatch
acExtendThisEntity
)
T
)
)
(setq lst_pt (remove_doubles lst_pt))
(foreach el lst_pt
(setq str_x (strcat " E=" (rtos (car el) 2 0) " ") ori_txt_x (* 3 pi 0.5))
(setq str_y (strcat " N=" (rtos (cadr el) 2 0) " ") ori_txt_y 0.0)
(mapcar
'(lambda (x / )
(setq nw_txt (vla-AddText Space (car x) (vlax-3d-point el) htx))
(vla-put-layer nw_txt "DIM-GRID")
(vla-put-StyleName nw_txt "$DIM-GRID")
(vla-put-Alignment nw_txt acAlignmentBottomLeft)
(vla-put-Rotation nw_txt (cdr x))
(vla-put-TextAlignmentPoint nw_txt (vlax-3d-point el))
(if (vlax-invoke nw_pl 'IntersectWith nw_txt acExtendThisEntity)
(vla-put-Alignment nw_txt acAlignmentBottomRight)
)
)
(list (cons str_x ori_txt_x) (cons str_y ori_txt_y))
)
)
(setq pt_ins (polar pt_ins (+ (* pi 0.25) (getvar "SNAPANG")) (* 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 "DIM-GRID")
(vla-put-StyleName nw_txt "$DIM-GRID")
(vla-put-Alignment nw_txt acAlignmentMiddleLeft)
(vla-put-Rotation nw_txt (getvar "SNAPANG"))
(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)
(setvar "SNAPANG" old_snapang)
(prin1)
)
