Mlh2 - Malha de Coordenadas

Quem (assim como eu) acha massante desenhar aquelas famigeradas linhas verticais e horizontais das malhas de coordenadas UTM nos desenhos? pior ainda se você quer recortá-las na altura do carimbo não é mesmo? bom, uns tempos atraz eu coloquei esta rotina pra download, mas acho que aqui pode-se aproveitar ela melhor...

---

(defun c:mlh2  (/ paper? again escala centro xvec viewctr
                ent box dcl xdisp prfx prfy laym layc int
                alt vars lays tmp minx miny adj maxx maxy
                n usap roty roty agrupa lst this offset
                alt2)
  (tbn:error-init (list (list "cmdecho" 0 "mirrtext" 0) t))
  (setq this   (vla-get-activedocument
                 (vlax-get-acad-object))
        paper?  (equal (vla-get-paperspace this)
                       (get-activespace))
        again   t
;|getd: calcula as coordenadas dos textos
tenho possibilidades: a esquerda/direita, alto/baixo,
angulo maior/menor que 90º
isso de qualquer forma combinada...|;
        getd
         (lambda (ladoa rot / ang1 f)
           (setq ang1 (get-tan-of-pt ent (if ladoa pa pb))
                 ang1 (if (> ang1 pi) (- ang1 pi) ang1)
                 f    (= ladoa (< ang1 (/ pi 2)))
                 f    (if rot (not f) f))
           (* (if ladoa -1 1)
            (if ord
              (if f
                (if (<= ang1 (/ pi 2))
                  (* adj (abs (tan (/ ang1 2))))
                  (* adj (abs (tan (/ (- ang1 (/ pi 2)) 2)))))
                (+ (/ adj (abs (sin ang1)))
                   (/ (+ alt2 adj) (abs (tan ang1)))))
              (if f
                  (* adj (abs (tan (/ (- ang1 (/ pi 2)) 2))))
                  (+ (/ adj (abs (cos ang1)))
                     (* (+ adj alt2) (abs (tan ang1))))))))
;função que desenha as linhas e os textos:
        draw
         (lambda
            (p1 p2 ord coord rot / lin ptsc pa
                  pb d txt ang adjl)
           (setq lin  (draw-line p1 p2 "0") ;temporária
;pontos que cruzam a pline temporaria:
                 ptsc (get-intersectpoints ent lin)
                 d    0
                 ang  (if ord 0 (/ pi 2)))
           (entdel (handent lin));apaga a linha temporária
           (if (> (length ptsc) 0)
             (progn
               (setq ptsc
                  (vl-sort ptsc
                       '(lambda (e1 e2)
                          (if ord  ;correção 10.11.2006
                            (> (car e1) (car e2))
                            (> (cadr e1) (cadr e2))))))
               (repeat (1- (length ptsc))
                 (setq pa (nth d ptsc)
                       pb (nth (1+ d) ptsc)
                       d  (1+ d))
                 (if (pointInPolygon enpts (media pa pb))
                   (setq txt (strcat (if (= "1" usap) ""
                                       (if ord prfx prfy))
                                     (fnum coord 0))
                         adjl(if rot (- adj) adj)
;desenha a linha e os textos, armazenando as HANDLE deles:
                         lst (append lst
                               (list
                                (draw-line pa pb laym)
                                (draw-text txt
                                  (mapcar '+ pa
                                   (if ord
                                     (list (getd t rot) adjl)
                                     (list adjl (getd t rot))))
                                  layt ang alt2 sty
                                  (if (= rot ord) "tr" "r"))
                                (draw-text txt
                                  (mapcar '+ pb
                                    (if ord
                                      (list (getd nil rot) adjl)
                                      (list adjl (getd nil rot))))
                                  layt ang alt2 sty
                                  (if (= rot ord) "tl" "l")
                                  )))))))))
        actions (lambda (key val / erro popsty poplaym poplayt)
;aplica o valor à variavel:
                  (if key (set (read key) val))
                  (setq erro ;verifica se tem erro:
                   (cond
                    ((= key "int")
                     (set_tile "int" (itoa (atoi val)))
                     (if (<= (atoi val) 0)
                       "O Intervalo tem que ser maior que zero"))
                    ((= key "alt")
                     (if (<= (atof val) 0)
                       "A Altura tem que ser maior que zero"))
                    ((= key "offset")
                     (if (< (atof val) 0)
                       "O Offset deve ser positivo"))
                    ((or (= key "layt") (= key "laym"))
                     (if (setq tmp (vl-position (strcase val)
                                     (mapcar 'strcase lays)))
                       (set_tile (strcat "pop" key) (itoa tmp)))
                     (if (not (validate-layname val))
                       "Nome de layer Inválido!!"))
                    ((or (= key "poplaym") (= key "poplayt"))
                     (setq key (vl-string-subst "" "pop" key)
                           val (nth (atoi val) lays))
                     (set (read key) val) (set_tile key val)
                     nil)
                    ((= key "popsty")
                     (setq sty (nth (atoi val) stys))
                     nil)))
;altera as MODE_TILE:
                  (mode_tile "prfx" (atoi usap))
                  (mode_tile "prfy" (atoi usap))
                  (mode_tile "accept" ;botão DESENHAR
                    (if (and (> (atoi int) 0)
                             (> (atof alt) 0)
                             (>= (atof offset) 0)
                             (validate-layname laym)
                             (validate-layname layt))
                      0 1))
                  (if erro
                    (progn (alert erro)
                      (mode_tile key 2)))))
  (while again ;enquanto é pra fazer
    (prompt
"\nSelecione a polilinha, viewport ou  para diagonal")
    (if (setq ent ;selecionou alguma coisa?
               (car (dxf -1 (ssget ":S"
                        '((0 . "*POLYLINE,VIEWPORT"))))))
      (if (wcmatch (dxf 0 ent) "*POLYLINE")
        (if ;foi uma VIEWPORT?
          (= "VIEWPORT" (dxf 0 (dxf 330 ent)))
          (setq ent   (ename-of (dxf 330 ent))
                enpts (get-points-polig ent)
                again nil)
;é uma pline:
          (if ;é fechada essa pline?
            (= 1 (logand 1 (dxf 70 ent)))
            (setq enpts (get-points-polig ent)
                  again nil)
            (if
              (equal
                (distance (vlax-curve-getstartpoint ent)
                          (vlax-curve-getendpoint ent))
                0.0
                0.001)
              (setq enpts (get-points-polig ent)
                    again nil)
              (prompt "\nA polilinha deve ser fechada"))))
        (setq enpts (get-points-polig ent)
              again nil))
;nao selecionou nada:
      (if (= 52 (getvar "errno")) ;clicou enter?
        (if (setq p1 (getpoint
              "\nEntre com o primeiro vértice"))
          (if (setq p2 (getcorner p1
              "\nEntre com o segundo vértice"))
;calcula as coordenadas do retângulo de diagonal P1 P2:
            (setq enpts (get-max-min-corners (list p1 p2))
                  enpts (mapcar
                          '(lambda (x) (trans x 1 0))
                          (list (car enpts)
                                (list (caadr enpts)
                                      (cadar enpts))
                                (cadr enpts)
                                (list (caar enpts)
                                      (cadadr enpts))))
                  again paper?)
            (setq again nil))
          (setq again nil))))
;se ENTPTS recebeu a lista de vertices...
    (if enpts
      (if ;vc esta no paperspace e pediu diagonal?
        paper?
        (if (= (dxf 0 ent) "VIEWPORT")
          (setq again nil)
          (while
            (progn
              (prompt "\nSelecione a ViewPort\n")
              (if (setq ent (car (dxf -1
                    (ssget ":S" '((0 . "VIEWPORT"))))))
                (setq again nil)
                (if (= 52 (getvar "errno"))
                  (setq again nil
                        enpts nil))))))))
;recalcula os pontos para o modelspace se necessário:
    (if (= (dxf 0 ent) "VIEWPORT")
      (setq ent     (vlax-ename->vla-object ent)
            escala  (vla-get-CustomScale ent)
            centro  (dxf 10 ent)
            xvec    (angle '(0 0) (dxf 111 ent))
            viewctr (progn
                      (vla-put-mspace this :vlax-true)
                      (vla-put-ActivePViewport this ent)
                      (command "redraw")
                      (setq xdisp (angle (trans '(0 0) 2 1)
                                    (trans '(1 0) 2 1)))
                      (trans (getvar "viewctr") 1 0))
;calcula as coordenadas PWCS->MWCS
            enpts   (mapcar
                      '(lambda (x)
                         (polar viewctr
                           (+ xvec xdisp (angle centro x))
                           (/ (distance x centro) escala)))
                      enpts))))
  (if enpts
    (progn
      (setq dcl  (load_dialog "f:/tbn/lisps/mlh2.dcl")
            vars '("poplaym" "poplayt" "popsty" "sty"
                   "prfx" "prfy" "laym" "layt" "int"
                   "alt" "usap" "roty" "rotx" "agrupa"
                   "offset")
            lays '("")
;lista dos layers:
            lays (get-tableof "layers")
;lista dos estilos de texto
            stys (get-tableof "textstyles")
;pline temporária
            ent  (draw-pline2 enpts (getvar "clayer") t))
      ;atribui às variaves, seus valores:
      (mapcar 
        '(lambda (k v / tmp)
           (set (read k)
             (if (setq tmp (getcfg
                   (strcat "Appdata/malha_coordenadas/" k)))
                  (if (/= "" tmp) tmp v) v)))
        (cdddr vars)
;valores padrão:
        '("Standard" "N=" "E=" "MALHA" "COORDENADAS"
          "100" "2" "1" "0" "0" "1" "0.5"))
      (new_dialog "malha" dcl);abre o dialogo
;popula as popup:
      (start_list "poplaym" 3)(mapcar 'add_list lays)(end_list)
      (start_list "poplayt" 3)(mapcar 'add_list lays)(end_list)
      (start_list "popsty" 3)(mapcar 'add_list stys) (end_list)
;atribui as ações das tiles do dialogo:
      (mapcar '(lambda (x)
                 (action_tile x "(actions $key $value)"))
              vars)
      (mapcar 'set_tile
              (cdr (cdddr vars))
              (list prfx prfy laym layt int alt usap
                    roty rotx agrupa offset))
;atribui às tiles, seus valores:
      (set_tile "popsty"
                (itoa (vl-position
                        (setq sty (if (member sty stys)
                                    sty (car stys)))
                        stys)))
      (if (member layt lays)
        (set_tile "poplayt" (itoa (vl-position layt lays))))
      (if (member laym lays)
        (set_tile "poplaym" (itoa (vl-position laym lays))))
;inicializa os MODE_TILE:
      (actions nil nil)
;inicia e espera o clique em "DESENHAR":
      (if (= 1 (start_dialog));desenha!!!
        (progn
;retangulo WCS da pline temporária que foi desenhada:
          (setq box  (get-max-min-corners enpts)
                tmp  (atoi int)
                minx (* tmp (1+ (fix (/ (caar box) tmp))))
                miny (* tmp (1+ (fix (/ (cadar box) tmp))))
                maxx (* tmp (fix (/ (caadr box) tmp)))
                maxy (* tmp (fix (/ (cadadr box) tmp)))
                alt2 (atof alt) ;altura do texto
                adj  (atof offset)
                n    minx)
;desenha as linhas verticais:
          (while (<= n maxx)
            (draw (list n (- (cadar box) tmp));PA
                  (list n (+ (cadadr box) tmp));PB
                  nil ;eixos verticais
                  n   ;coordenada
                  (= roty "1")); por cima ou por baixo?
            (setq n (+ n tmp)))
;desenha as linhas horizontais:
          (setq n miny)
          (while (<= n maxy)
            (draw (list (- (caar box) tmp) n)
                  (list (+ (caadr box) tmp) n)
                  t n (= rotx "1"))
            (setq n (+ n tmp)))
          (if (= agrupa "1") ;agrupar as entidades?
            (vla-AppendItems
              (vla-add (vla-get-Groups this) (car lst))
              (vlax-safearray-fill
                (vlax-make-safearray
                  vlax-vbObject
                  (cons 0  (1- (length lst))))
                (mapcar
                  '(lambda (x) ;converte as HANDLE em VLA
                     (vlax-ename->vla-object(handent x)))
                  lst))))
;salva as configurações para uso posterior:
          (mapcar
            '(lambda (k)
               (setcfg
                 (strcat "Appdata/malha_coordenadas/" k)
                 (eval (read k))))
            (cdddr vars))))
      (entdel (handent ent));apaga a pline temporaria
      (unload_dialog dcl)))
;vc estava numa viewport? volta pra ela...
  (if viewctr (vla-put-mspace this :vlax-false))
  (tbn:error-restore))

---

agora o dcl, obviamente que ele deve estar numa pasta que o autocad ache...

---

malha :dialog {label="Desenhar malha de coordenadas";
:row{
  :boxed_column {label = "Prefixos";
    :toggle {key="usap";label="&Sem Prefixo";}
    :edit_box {key="prfx"; label="&X:";}
    :edit_box {key="prfy"; label="&Y:";}}
  :boxed_column {label="Textos";
    :row {
      :column{
        :edit_box {key="int";    label="&Intervalo:";}
        :edit_box {key="alt";    label="&Altura:     ";}
        :edit_box {key="offset"; label="&Offset:     ";}}
      :column {
        :toggle {key = "roty"; label = "Y por &baixo";}
        :toggle {key = "rotx"; label = "X a es&querda";}
        :toggle {key = "agrupa"; label = "Agrupar";}}}
    :popup_list {key="popsty"; label="&Estilo:";}}}
  :boxed_column { label = "Layers";
    :row {
      :popup_list {key="poplaym"; label="Malha:";
                   width=40; fixed_width=true;}
      :edit_box {key="laym"; width=20; fixed_width=true;}}
    :row {
      :popup_list {key="poplayt"; label="Texto: ";
                   width=40; fixed_width=true;}
      :edit_box {key="layt";width=20;fixed_width=true;}}}
  :row { :text {label="Powered by Neyton®";}
    :button {key = "cancel";
             is_cancel = true;
             label="Sai&r";}
    :button {key = "accept";
             is_default = true;
             label="&Desenhar";}}}

---

salve o arquivo LSP e o arquivo DCL numa pasta que você saiba que está na support file do cad.
A rotina desenha linhas e textos, estes estarão referenciados ao WCS, não importando a rotação/translação do seu UCS. Também não importa se o desenho está no modelspace ou paperspace, pois ela só desenha no MODEL.
Se preferir, pode desenhar a malha apartir de 2 pontos em diagonal, ou apartir de uma polilinha predefinida, ou até mesmo duma VIEWPORT (normal ou poligonal)
em caso de bug, poste um comentário explicando como chegou nele, pode ser??
talvez você precise colocar um (vl-load-com) no início da rotina, ok?

---

Link(s) da(s) subrotina(s) usada(s):
tbn:error-init, get-activespace, get-tan-of-pt, tan, draw-line, get-intersectpoints, pointInPolygon, media, fnum, draw-text, validate-layname, dxf, ename-of, get-points-polig, get-max-min-corners, get-tableof, draw-pline2, tbn:error-restore