AutoCota, AutoArea

Opa e aí minha gente!! Bom, hoje vou postar uma rotina que eu fiz a muito tempo, quando trabalhava num escritório de topografia em Curitiba.
Bom a lisp faz o seguinte: você seleciona algumas polilinhas e cjama o comando. Este irá mostrar algumas opções e irá cotar todos os segmentos dessa polilinha.

Tá e daí? você pergunta.

Imagine que você tem um loteamento, subdivisão ou coisa assim e precisa cotar todos os segmentos das polilinhas. É primeiro que você deveria considerar usar o Parcels do Civil 3D... Mas se você só tem o AutoCAD, pode usar a lisp!!

Por exemplo, temos estas polilinhas:

Aí chamamos a lisp AUTOCOTA Selecionamos todas as polilinhas, e a tela se abre: 

Você marca as opções e clica OK.
As opções como você pode ver, são auto explicativas. A não ser a opção "Por Dentro", é por dentro ou por fora da polilinha. Só isso.
A outra opção que pode causar confusão é a "Com Azimute".

Quer dizer que ela põe azimute na cota?

É, coloca... hehehe, posição, topograph, desculpa aí, hehehe a cereja do bolo vem na hora que "estrcharmos" as polilinhas, hehehe.


Bom, o resultado será: 

Agora, e se precisarmos adicionar a área de cada polilinha?

Aí chamamos o comando AUTOAREA.

Será pedido a seleção das polilinhas e em seguinda será aberto a tela:

Também é autoexplicativo. O item "Calcula rotação", se marcado, analiza a polilinha e alinha o texto criado no sentido maior da polilinha.


O resultado será:

É isso. E a lisp?, bom, é esta:

---

;subrotina que implementa as ações do DCL
;key é a key usada no item do dcl
;prog indica se é o autocota ou autoarea
;algumas ações dos dois programas são identicas
;então preferi simplificar
(defun autoactions (key val prog)
  (setq f t)
  (cond    ((= key "layer")
     (if (snvalid val)
       (setq layer val)
       (alert "Nome de layer Inválido!!")
     )
     (set_tile "poplay"
           (if (setq tmp (vl-position
                   (strcase val)
                   (mapcar 'strcase lays)
                 )
               )
             (itoa tmp)
             "0"
           )
     )
    )
    ((= key "poplay")
     (set_tile "layer" (setq layer (nth (atoi val) lays)))
    )
    ((= key "offset")
     (if (<= (atof val) 0)
       (alert "Offset Inválido")
       (setq offset val)
     )
    )
    ((= key "altura")
     (if (> (atof val) 0)
       (setq altura val)
       (alert "Altura Inválida")
     )
    )
    ((= key "az") (setq az val))
    ((= key "dentro") (setq dentro val))
    ((= key "duplicidade") (setq duplicidade val))
    ((= key "srot") (setq srot val))
    ((= key "dimstyle") (setq dimstyle (nth (atoi val) dims)))
    ((= key "txtstyle") (setq txtstyle (nth (atoi val) stys)))
    ((= key "prefixo") (setq prefixo val))
    ((= key "sufixo") (setq sufixo val))
    ((= key "suf") (setq suf val))
    ((= key "prf") (setq prf val))
  )
  (mode_tile "accept"
         (if (and (if prog
            (> (atof offset) 0)
            (> (atof altura) 0)
              )
              (snvalid layer)
         )
           0
           1
         )
  )
  (mode_tile "prefixo"
         (if (= prf "1")
           0
           1
         )
  )
  (mode_tile "sufixo"
         (if (= suf "1")
           0
           1
         )
  )
)

;rotina principal do autocota
(defun c:autocota (/      ss     ent    pts    n      cont   vla
           p1      p2     p3    bul    clock? activespace
           xdir      vars     offset    r      h      d         ang
           lst      flag     dim    az     layer  dimstyle
           dims      tmp     dentro
          )
  ;controle de erros
  (tbn:error-init (list (list "cmdecho" 0) t))

  (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (progn
      
      (setq dcl        (load_dialog
              "D:\\PROGRAMAS\\LISP\\tbn2\\LISPS\\autocota.dcl"
            )
        ;angulo do eixo X do UCS
        xdir    (angle (trans '(0 0) 0 1) (trans '(1 0) 0 1))
        ;lista dos layers disponiveis
        lays    (vl-sort (get-tableof "layers")
                 '(lambda (e1 e2) (< (strcase e1) (strcase e2)))
            )
        ;lista dos dmension styles
        dims    (get-tableof "dimstyles")
        ;lista auxiliar
        vars    '("offset" "layer" "az" "dentro"
              "dimstyle" "duplicidade")
        ;model ou paper:
        activespace    (get-activespace)
      )

      ;lembra as configurações anteriores do DCL
      (mapcar
    '(lambda (k v / tmp)
       (set    (read k)
        (if (setq tmp (getcfg (strcat "Appdata/autocota/" k)))
          (if (/= "" tmp)
            tmp
            v
          )
          v
        )
       )
     )
    vars
    ;valores padrão caso não haja valores a lembrar
    (list "1.0" "TEX_COTAS" "0" "0" (car dims) "1")
      )

      ;carrega o dcl do autocota
      (new_dialog "autocota" dcl)

      ;define as acoes de todos os controles do dcl
      (foreach x (cons "poplay" vars)
    (action_tile x "(autoactions $key $value t)")
      )

      ;calcula o dimstyle inicial
      (if (not (setq tmp
              (vl-position (strcase dimstyle) (mapcar 'strcase dims))
           )
      )
    (setq dimstyle (car dims)
          tmp      0
    )
      )

      ;preenche o combobox dos layers
      (start_list "poplay" 3)
      (mapcar 'add_list lays)
      (end_list)
      
      ;preenche o combobox do dmension style
      (start_list "dimstyle" 3)
      (mapcar 'add_list dims)
      (end_list)

      ;preenche os outros controles do dcl
      (set_tile "az" az)
      (set_tile "offset" offset)
      (set_tile "dentro" dentro)
      (set_tile "duplicidade" duplicidade)
      (set_tile "dimstyle" (itoa tmp))

      ;força a desabilitar ou habilitar os botões
      ;em função dos valores dos mesmos
      ;é uma validação dos dados
      (autoactions "layer" (set_tile "layer" layer) t)

      ;inicia o dialogo
      (if (= 1 (start_dialog))
    (progn
      ;prepara as variaveis para desenhar
      (setq    offs (*    (if (= "1" dentro)
              -1
              1
            )
            (atof offset)
             )
      )
      ;repita em todas as polilinhas selecionadas
      (repeat (if ss
            (sslength ss)
            0
          )
        ;pega a polilinha
        ;verifica se esta em sentido horário
        ;verifica o numero de vertices (dxf 90)
        (setq ent     (ssname ss 0)
          vla     (vlax-ename->vla-object ent)
          clock? (isclockwise (get-points-polig ent))
          n     0
          qtd     (dxf 90 ent)
        )
        ;para todos os segmentos da plilinha
        (repeat (if    (= :vlax-true (vla-get-closed vla))
              qtd
              (1- qtd)
            )
          ;calcula o ponto inicial e final
          ;e se tem arco no segmento
          (setq p1     (append (3d-of-vla (vla-get-coordinate vla n))
                 '(0.0)
             )
            bul     (vla-getbulge vla n)
            n     (1+ n)
            p2     (append (3d-of-vla (vla-get-coordinate
                          vla
                          (if (= n qtd)
                        0
                        n
                          )
                        )
                 )
                 '(0.0)
             )
            p3     (media p1 p2)
            ang     (+ (/ pi 2) (angle p1 p2))
            flag t
          )
          
          ;verifica se o segmento já foi cotado
          ;se esta for uma opção escolhida
          (if (= "1" duplicidade)
        (foreach l lst
          (if (or (and (not (ponto-dif? p1 (car l)))
                   (not (ponto-dif? p2 (cadr l)))
              )
              (and (not (ponto-dif? p1 (cadr l)))
                   (not (ponto-dif? p2 (car l)))
              )
              )
            (setq flag nil)
          )
        )
          )

          ;caso o inicio e o fim do segmento sejam diferentes
          ;ou seja, o segmento tem comprimento>0
          ;e ainda, já não foi cotado
          (if (and (ponto-dif? p1 p2) flag)
        (progn
          ;cria a dimension apropriada
          (setq    lst (cons (list p1 p2) lst)
            dim (if    (zerop bul)
                  ;dimension aligned
                  (vla-AddDimAligned
                activespace
                (vlax-3d-point p1)
                (vlax-3d-point p2)
                (vlax-3d-point
                  (polar p3
                     ang
                     (* (if    clock?
                          1
                          -1
                        )
                        offs
                     )
                  )
                )
                  )
                  ;dimension em arco
                  (progn
                (Setq d    (distance p1 p2)
                      h    (* bul d 0.5)
                      r    (/ (+ (expt h 2) (/ (expt d 2) 4))
                       (* bul d)
                    )
                )
                (vla-addDimArc
                  activespace
                  (vlax-3d-point (polar p3 ang (- r h)))
                    ;centro
                  (vlax-3d-point p1)
                  (vlax-3d-point p2)
                  (vlax-3d-point
                    (polar p3
                       ang
                       (- (* (if clock?
                           1
                           -1
                         )
                         offs
                          )
                          h
                       )
                    )
                  )
                )
                  )
                )
          )
          ;sobreescreve alguns dxf:
          ;1 é o texto escrito
          ;3 é o estilo
          ;8 é o layer
          ;51 é o ângulo do X do UCS,
          ;ele evita que o texto fique de cabeça pra baixo
          (remake-ent
            dim
            '(1 3 8 51)
            (list (if (= az "1")
                (strcat
                  "<> - "
                  (format-ang2 (angle p1 p2) nil "Azimute" 4)
                )
                "<>"
              )
              dimstyle
              layer
              xdir
            )
          )

          ;implmenta o componente de azimute se esta for
          ;requerido. O xdata serve para o reactor que o
          ;corrige ao strechar a domension
          (if (= az "1")
            (put-xdata2
              dim
              '((1000 . "N")
            (1000 . "A")
            (1000 . "M")
            (1000 . "<> - []")
               )
              "AUTOCOTA"
            )
          )
          ;implementa o reactor que corrige o azimute
          (if (= az "1")
            (vlr-object-reactor
              (list dim)
              ""
              '((:vlr-modified . autocota:update))
            )
          )
        )
          )
        )
        ;vai pra próxima polilinha
        (ssdel ent ss)
      )
      ;salva as opções do dcl para lembrar depois
      (foreach k vars
        (setcfg (strcat "Appdata/autocota/" k) (eval (read k)))
      )
    )
      )
      (unload_dialog dcl)
    )
  )
  ;restaura o controle de erros
  (tbn:error-restore)
)

;reactor que corrige os azimutes
;ele agenda a correção do azimute quando
;a edição do usuário termina.
(defun autocota:update (vla rea par)
  (if (not (vlax-erased-p vla))
    (vlr-editor-reactor
      (list vla rea)
      '((:vlr-commandEnded . autocota:doupdate))
    )
  )
)

;quando a edição (move, stretch...) termina
;atualiza o azimute
(defun autocota:doupdate (rea com / oldr ent)
  (setq    tmp  (vlr-data rea)
    ent  (car tmp)
    oldr (cadr tmp)
  )
  ;desabilita os reactors temporariamente
  (vlr-remove rea)
  ;ajusta o azimute e restaura o reactor
  (autocota:formatadata
    ent
    (list oldr)
    (get-xdata2 ent "AUTOCOTA")
  )
)

;rotina que procede o ajuste do azimute
(defun autocota:formatadata (vla oldr xd / aa)
  ;tira qualquer reactor da dimension
  ;para que a edição não os dispare
  (foreach aa oldr (vlr-owner-remove aa vla))
  ;edita
  (vla-put-TextOverride
    vla
    (vl-string-subst
      (format-ang2
    (angle (dxf 13 ent) (dxf 14 ent))
    (= "S" (car xd))        ;COM ESPAÇOS
    (cadr xd)            ;AZIMUTE/RUMO
    (caddr xd)            ;PRECISAO
      )
      "[]"
      (if (cadddr xd)
    (cadddr xd)
    "<> - []"
      )
    )
  )
  ;salva as xdata
  (put-xdata2
    vla
    (mapcar '(lambda (x) (cons 1000 x)) xd)
    "AUTOCOTA"
  )
  ;reestabelece os reactors
  ;sem isso, dá pau, hehehe
  (foreach aa oldr (vlr-owner-add aa vla))
)

;rotina que atva os reactors do desenho quando
;este é aberto pela primeira vez
(defun autocota:ativatodososreactors (/ tmp ss ent)
  ;antes de adicionar um reactor, verificar se
  ;ele já existe, se existir, apague
  (mapcar
    '(lambda (r / tmp)
       (setq tmp (mapcar 'cdr (vlr-reactions r)))
       (if
     (or (member 'autocota:doupdate tmp)
         (member 'autocota:update tmp)
     )
      (vlr-remove r)
       )
     )
    (apply 'append (mapcar 'cdr (vlr-reactors)))
  )

  ;em todas as dimensions gerenciadas pelo autocota
  (setq ss (ssget "X" '((0 . "DIMENSION") (-3 ("AUTOCOTA")))))
  (repeat (if ss
        (sslength ss)
        0
      )
    (setq ent (ssname ss 0))
    ;crie o reactor de atualização do azimute
    (vlr-object-reactor
      (list (vlax-ename->vla-object ent))
      ""
      '((:vlr-modified . autocota:update))
    )
    (ssdel ent ss)
  )
  (princ)
)

;rotina que cria um texto com a área das polilinhas selecionadas
;caso a polilinha seja alterada, ela atualiza a área escrita no texto
(defun c:autoarea (/      ss     ent    area   reg    altura rot
           d      n     tmp    r      layer  txtstyle
           stys      cg     vars    prefixo          sufixo prf
           suf      txt     p    f      srot
          )
  ;controle de erros inicializado
  (tbn:error-init (list (list "cmdecho" 0) t))

  ;nas polilinhas selecionadas
  (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (progn
      ;carrege as variaveis iniciais
      (setq dcl     (load_dialog "f:/tbn/lisps/autocota.dcl")
        ;lista dos layers do desenho
        lays (vl-sort (get-tableof "layers")
              '(lambda (e1 e2) (< (strcase e1) (strcase e2)))
         )
        ;lista dos estilos de texto
        stys (get-tableof "textstyles")

        ;lista dos controles do dcl
        vars '("poplay"    "txtstyle"  "layer"     "altura"
           "prefixo"   "sufixo"       "prf"       "suf"
           "srot"
          )
        rot     (/ pi 180)
      )

      ;lembra as escolhas antereiores do dcl
      (mapcar
    '(lambda (k v / tmp)
       (set    (read k)
        (if (setq tmp (getcfg (strcat "Appdata/autoarea/" k)))
          (if (/= "" tmp)
            tmp
            v
          )
          v
        )
       )
     )
    (cdr vars)

    ;se não há o que lembrar, use os padrões
    (list (car stys) "TEX_AREAS" "1.5" "Área=" "m²" "1" "1" "1")
      )

      ;inicializa o dcl
      (new_dialog "autoarea" dcl)

      ;define as ações de cada controle do dcl
      (foreach x vars
    (action_tile x "(autoactions $key $value nil)")
      )

      ;popula o combobox dos layers
      (start_list "poplay" 3)
      (mapcar 'add_list lays)
      (end_list)

      ;popula o combobox dos estilos de texto
      (start_list "txtstyle" 3)
      (mapcar 'add_list stys)
      (end_list)

      ;preenche os demais campos
      (foreach x (cddr vars) (set_tile x (eval (read x))))
      (set_tile    "txtstyle"
        (itoa (if (setq    tmp (vl-position
                      (strcase txtstyle)
                      (mapcar 'strcase stys)
                    )
              )
            tmp
            0
              )
        )
      )

      ;força a habilitar ou desabilitar campos em função
      ;das escolhas atuais
      (autoactions "layer" (set_tile "layer" layer) nil)

      ;mostra o dcl
      (if (= 1 (start_dialog))
    (progn
      ;se clicou ok, proceda em todas as polilinhas
      (repeat (sslength ss)
        (setq ent  (ssname ss 0)
          area (vlax-curve-getarea ent)
          n    0
          d    1e30
          ;calcula uma region temporária,
          ;para obter o centroide da polilinha
          reg  (regionme ent)
        )

        ;se conseguir criar a region temporária
        (if    reg
          (progn
        ;calcula o centroide da mesma.
        ;nele será escrito o texto com a área
        (setq cg
               (append (3d-of-vla (vla-get-centroid reg)) '(0.0))
        )

        ;se a polilinha é mais comprida que larga,
        ;alinha o texto no sentido mais extenso da mesma
        ;se esta for uma opção marcada
        (if (= "1" srot)
          (repeat 181
            (vla-rotate reg (vlax-3d-point cg) rot)
            (Setq box (get-bounding-box reg)
              tmp (- (caadr box) (caar box))
              n   (1+ n)
            )
            (if    (< tmp d)
              (Setq d tmp
                r n
              )
            )
          )
        )

        ;apaga a region temporária
        (vla-delete reg)

        ;calcula os componentes do texto
        (setq p      (if (= prf "1")
                prefixo
                ""
              )
              f      (if (= suf "1")
                sufixo
                ""
              )
              ;desenha o texto na tela
              txt (draw-text (strcat p (fnum area 2) f)
                     cg
                     layer
                     (rot-of-ucs
                       (if (= "1" srot)
                     (+ (/ pi 2) (* -1 r rot))
                     0
                       )
                     )
                     (atof altura)
                     txtstyle
                     "mc"
              )
        )

        ;cria o xdata que serve de informação ao reactor
        (put-xdata2 ent (list (cons 1005 txt)) "AUTOAREA")

        ;cria o xdata que serve de informação ao reactor
        ;essa informação vincula o txt a polilinha
        (put-xdata2
          txt
          (list (cons 1000 p) (cons 1000 f))
          "AUTOAREA_PF"
        )

        ;inicializa o reactor
        (autoarea:cria_reactor ent)
          )
        )

        ;proxima polilinha
        (ssdel ent ss)
      )

      ;slava as opções do dcl para lembrar depois
      (foreach k (cdr vars)
        (setcfg (strcat "Appdata/autoarea/" k) (eval (read k)))
      )
    )
      )
      ;descarrega o dcl
      (unload_dialog dcl)
    )
  )
  ;restaura o controle de erros
  (tbn:error-restore)
)

;subrotina que cria o reactor de atualização da área
(defun autoarea:cria_reactor (ent)
  (vlr-object-reactor
    (list (vlax-ename->vla-object ent))
    nil
    '((:vlr-modified . autoarea:update))
  )
)

;subrotina que ativa a atualização das áreas
;quando o desenho é aberto
(defun aautoarea:ativa_reactor (/ ss ent)
  ;se já existir um reactor vinculado ao txt, desabilite antes
  (mapcar
    '(lambda (r)
       (if (member 'autoarea:update (mapcar 'cdr (vlr-reactions r)))
     (vlr-remove r)
       )
     )
    (apply 'append (mapcar 'cdr (vlr-reactors)))
  )

  ;cria o reactor em todas as polilinhas gerenciadas pelo autoarea
  (repeat (if (setq ss (ssget "X" '((0 . "LWPOLYLINE") (-3 ("AUTOAREA")))))
        (sslength ss)
        0
      )
    (setq ent (ssname ss 0))
    (autoarea:cria_reactor ent)
    (ssdel ent ss)
  )
)

;subrotina que atualiza o text
(defun autoarea:update (ent rea par / area xd txt)
  (if (not (wcmatch (getvar "cmdnames") "*SAVE*"))
    (if    (not (vlax-erased-p ent))
      (setq txt     (car (get-xdata2 ent "AUTOAREA"))
        area (vlax-curve-getarea ent)
        xd     (get-xdata2 txt "AUTOAREA_PF")
        txt     (if xd
           (remake-ent
             txt
             1
             (strcat (car xd) (fnum area 2) (cadr xd))
           )
         )
      )
    )
  )
)

;rotina que formata as cotas do autocota com quebras de linha
;ou sem quebras
(defun c:arrumacota (/ ent xd lst str oldr reas X vla)
  (tbn:error-init (list (list "cmdecho" 0) t))

  ;lista das possiveis formatações
  (Setq    lst  '("<> - []" "<>\\P[]" "[]\\P<>" "[]" "<>")
    reas (cdar (vlr-reactors :VLR-Object-Reactor))
  )

  ;procede o comando enquanto o usuário não interromper
  (while (progn
       (prompt "\nSelecione a cota:")
       (setq ent (ssget ":S" '((-3 ("AUTOCOTA")))))
     )

    ;pega a cota selecionada
    ;substitui pela nova formatação
    (setq ent  (ssname ent 0)
      vla  (vlax-ename->vla-object ent)
      xd   (get-xdata2 ent "AUTOCOTA")
      str  (vl-position
         (if (cadddr xd)
           (cadddr xd)
           "<> - []"
         )
         lst
           )
      oldr nil
      str  (nth (if    (= 4 str)
              0
              (1+ str)
            )
            lst
           )
    )

    ;desliga o reactor que tem sobre a cota
    (foreach x reas
      (if (member vla (vlr-owners x))
    (setq oldr (cons x oldr))
      )
    )

    ;atualiza a cota e religa o reactor
    (autocota:formatadata
      vla
      oldr
      (append (sub-list xd 0 2) (list str))
    )
  )

  ;restaura o controle de erros
  (tbn:error-restore)
)


;liga todos os reactor quando a rotina é carregada
;ou quando o desenho é aberto pela primeira vez
(aautoarea:ativa_reactor)
(autocota:ativatodososreactors)

; verifica se dois pontos são muito proximos
(defun ponto-dif? ( p1 p2 / )
  (> (distance p1 p2) 0.001))

---

Link(s) da(s) subrotina(s) usada(s):
tbn:error-init, get-tableof, get-activespace, isclockwise, get-points-polig, dxf, 3d-of-vla, media, ponto-dif, remake-ent, format-ang2, put-xdata2, tbn:error-restore, get-xdata2, cg, regionme, get-bounding-box, draw-text, fnum, rot-of-ucs, sub-list

Para complementar, faltou o DCL, abaixo 

---

autocota : dialog {label = "AutoCota";
 :boxed_column {label ="Cota";
   :popup_list{key =  "dimstyle";}
   :row {
     :toggle {label = "Com Azimute"; key = "az";}
     :toggle {label = "Remove Duplicidade"; key = "duplicidade";}}
   }
 :boxed_column{ label = "Offset";
   :edit_box {key = "offset";}
   :toggle {label = "Por Dentro"; key = "dentro";}}
 :boxed_column{label = "Layer";
   :popup_list{ key = "poplay";}
   :edit_box {key="layer";}}
 :row{ :text {label="Powered by Neyton®";}   ok_cancel;}}

autoarea : dialog {label = "AutoÁrea";
 :boxed_column{ label = "Texto:";
   :popup_list {key = "txtstyle";}
   :row {
     :toggle {key="srot";label="Calcula rotação";}
     :edit_box { label = "Altura"; key = "altura";}}}
 :boxed_column {label = "Incluir...";
   : row {
      :toggle {label = "Prefixo"; key = "prf";}
      :edit_box { key = "prefixo"; width = 40;}}
   : row {
     :toggle {label = "Sufixo "; key = "suf";}
     :edit_box { key = "sufixo"; width = 40;}}
 }
  :boxed_column{label = "Layer";
   :popup_list{ key = "poplay";}
   :edit_box {key="layer";}}
 :row{ :text {label="Powered by Neyton®";}   ok_cancel;}
} 

---

Para que funcione, você deverá copiar todo o código acima. Bem como todas as subrotinas usadas pelo programa (os links estão acima)

Tá eu sei que fazer isso é massante.... Entre no tbn2net.com para baixar o programa já compilado.

Se você leu este post até aqui, parabéns!!! Você provavelmente está interessado no código fonte do programa. Se este é o caso, por favor, entre em contato comigo, podemos trocar umas idéias!!