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" 0t))
  (
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 piang1)
                 
f    (= ladoa (< ang1 (/ pi 2)))
                 
f    (if rot (not ff))
           (
* (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 ptsc0)
             (
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+ dptsc)
                       
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 (- adjadj)
;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 rotadjl)
                                     (
list adjl (getd t rot))))
                                  
layt ang alt2 sty
                                  (if (= rot ord"tr" "r"))
                                (
draw-text txt
                                  (mapcar '+ pb
                                    (if ord
                                      (list (getd nil rotadjl)
                                      (
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 keyval))
                  (
setq erro ;verifica se tem erro:
                   (cond
                    ((= key "int")
                     (
set_tile "int" (itoa (atoi val)))
                     (
if (<= (atoi val0)
                       
"O Intervalo tem que ser maior que zero"))
                    ((
= key "alt")
                     (
if (<= (atof val0)
                       
"A Altura tem que ser maior que zero"))
                    ((
= key "offset")
                     (
if (< (atof val0)
                       
"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 vallays))
                     (
set (read keyval) (set_tile key val)
                     
nil)
                    ((
= key "popsty")
                     (
setq sty (nth (atoi valstys))
                     
nil)))
;altera as MODE_TILE:
                  (mode_tile "prfx" (atoi usap))
                  (
mode_tile "prfy" (atoi usap))
                  (
mode_tile "accept" ;botão DESENHAR
                    (if (and (> (atoi int0)
                             (
> (atof alt0)
                             (
>= (atof offset0)
                             (
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 02 1)
                                    (
trans '(1 02 1)))
                      (
trans (getvar "viewctr"1 0))
;calcula as coordenadas PWCS->MWCS
            enpts   (mapcar
                      '(lambda (x)
                         (
polar viewctr
                           (+ xvec xdisp (angle centro x))
                           (
/ (distance x centroescala)))
                      
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 (/= "" tmptmp vv)))
        (
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 boxtmp))))
                
miny (* tmp (1+ (fix (/ (cadar boxtmp))))
                
maxx (* tmp (fix (/ (caadr boxtmp)))
                
maxy (* tmp (fix (/ (cadadr boxtmp)))
                
alt2 (atof alt;altura do texto
                adj  (atof offset)
                
n    minx)
;desenha as linhas verticais:
          (while (<= n maxx)
            (
draw (list n (- (cadar boxtmp));PA
                  (list n (+ (cadadr boxtmp));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 boxtmpn)
                  (
list (+ (caadr boxtmpn)
                  
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

11 comentários:

  1. Voce precisa copiar as subrotinas que estão embutidas na rotina mlh2

    Estas ( e outras subrotinas ) já foram postadas anteriormente e, na página do blog elas aparecem como hiperlinks, acesse-os e verás os códigos que completam esta rotina, ah, so faltou definir a subrotina TAN ( tangen de um angulo ), mas já estou providenciando, ok?

    ResponderExcluir
  2. Vou tentar e te escrevo.

    Obrigado e mais uma vez, parabéns!

    ResponderExcluir
  3. Cara, atualizei a rotina... algumas pessoas usam o UCS da viewport rotacionado, acompanhando a direção da malha de coordenadas... isso cria um problema, pois a margem, que normalmente está no paperspace acompanha o WCS do PAPER... então tenho de calcular os pontos corretos da projeção da viewport no modelspace levando em conta a translação, escala e rotação da janela da viewport... mas acho que agora está ok... ah, atualizei um link para a subrtina "get-points-polig" que estava faltando

    ResponderExcluir
  4. Neyton de Deus, me ajuda!!! hehe!!

    Está dando a seguinte mensagem de erro:

    GET-POINTS-POLIG
    undoing

    Uso o CAD 2004.

    Abraços!

    ResponderExcluir
  5. Copiei sim e deu este pepino.
    Na verdade, quando eu carrego a rotina aparece esta mensagem:

    APPLOAD malha.LSP successfully loaded.

    Command: ; error: Automation Error. Calling method SetObjectId of interface
    IAcadBaseObject failed

    Command:

    E agora, quem poderá me ajudar?? hehe!

    ResponderExcluir
  6. qual a versao do seu autocad?

    até o 2002 eu agarantiohhh que funcioniahhh!!! hehehe, brincadeira...

    mande a sua rotina pra eu analizar... mande no meu email

    esse erro eu nunca vi antes...

    ResponderExcluir
  7. todas as sub-lisp são .lsp?
    qdo dou o comando pra fazer a malha aparece Error: no function definition: VLAX-GET-ACAD-OBJECT
    como tenho que salvar esse codigo ja peguei todos os codigos e salvei de todas as formas que pensei. devo estar fazendo besteira na hora de salvar, nome e extensão, agradeço se puder me ajudar.
    valeu a atenção

    ResponderExcluir
  8. todas as sub-lisp são .lsp?
    qdo dou o comando pra fazer a malha aparece Error: no function definition: VLAX-GET-ACAD-OBJECT
    como tenho que salvar esse codigo ja peguei todos os codigos e salvei de varias formas. devo estar fazendo besteira na hora de salvar, nome e extensão, agradeço se puder me ajudar.

    ResponderExcluir
  9. talvez você não esteja ainda familiarizado com as novas extensões activx do visual lisp, esta função que você mencionou é uma delas... para que a rotina funcione é necessário carregar estas extensões, para tal, faça o sequinte, cole a linha abaixo:

    (vl-load-com)

    no inicio da rotina, pode ser fora do "defun"

    ela é a responsável por carregar estas extensões

    uma dica: todas as funções iniciadas por VL, VLA, VLAX, VLR são extensões do activex e só funcionam depois de carregadas com o ( vl-load-com ), blz?

    ResponderExcluir
  10. Olá, Neyton!
    estou tentando usar esta rotina, mas quando tento carregar me aparece a seguinte mensagem: "; error: malformed list on input"... estranho pq ninguém se queixou deste erro, mas eu copiei e colei sem fazer alteração alguma na lisp!

    ResponderExcluir