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!!