EDITAR ROTINA - ÁREA PARA NIVEL
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
olá a todos, gostaria de editar essa rotina, alguém poderia me dar um help.
NO ARQUIVO DCL
///////////////////////////////////////////////////////////////////////////////
AT_TELA_AREAS : dialog
{label = "STANDARD ÁREAS";
:row{
: boxed_column{ label="[ SELECIONE ]";
: popup_list {label = "AMBIENTE ";key = "LAREAS";fixed_width=true;width=30;edit_width =35;}
: popup_list {label = "ACABAMENTO" ;key = "LREVES";fixed_width=true;width=30;edit_width =35;} NAO LER REVESTIMENTO
:edit_box {label = "RN";key = "NIVEPR";edit_width=20;}
}
}
:column {
:row{ label="";
: button {label = "OK!! SAIR" ; key = "BT-SAIR" ; fixed_width=true;width=15;alignment=centered;}
: button {label = "POLIGONO"; key = "BT-SELECIONE" ; fixed_width=true;width=15;alignment=centered;is_default=true;}NAO SELECIONAR
: button {label = "INTERNO" ; key = "BT-INDICARPON" ; fixed_width=true;width=15;alignment=centered;is_default=true;}
}
}
}
///////////////////////////////////////////////////////////////////////////////
NA ROTINA
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFUN C:AX () (C:AT-AREASX));;;;;;;;;;;;;;AT-NIVEL NOME DA NOVA ROTINA
;............................
(DEFUN C:AT-AREASX ();;;;;;;;;;;AT-NIVEL NOME DA NOVA ROTINA
(SETQ FLAGOK nil)
;
(IF (NOT FLAG-XLS) (AT-LEARQXLS) )
;
(SETQ DCL_ID (LOAD_DIALOG "STANDARD"))
(SETQ FLAGOK1 T)
(SETQ XFIM1 0)
;
(WHILE FLAGOK1
(NEW_DIALOG "AT_TELA_AREAS" DCL_ID)
(START_LIST "LAREAS") (MAPCAR 'ADD_LIST LLAREAS) (END_LIST)
(START_LIST "LREVES") (MAPCAR 'ADD_LIST LLREVES) (END_LIST)
(IF (NOT NLA) (SETQ NLA "0"))
(IF (NOT NLR) (SETQ NLR "0"));;;;;;;;não ler mais no excel o revestimento
(IF (NOT NIVEPR) (SETQ NIVEPR "+"))
(SET_TILE "LAREAS" NLA)
(SET_TILE "LREVES" NLR);;;;;;;;não ler mais no excel o revestimento
(SET_TILE "NIVEPR" NIVEPR)
(ACTION_TILE "LAREAS" "(SETQ NLA $value)")
(ACTION_TILE "LREVES" "(SETQ NLR $value)");;;;;;;;não ler mais no excel o revestimento
(ACTION_TILE "NIVEPR" "(SETQ NIVEPR $value)")
(ACTION_TILE "BT-SELECIONAR" "(DONE_DIALOG 1)");;;;;;;;;;;;; não trabalhar no sistema de seleção
(ACTION_TILE "BT-INDICARPON" "(DONE_DIALOG 2)");;;;;;;;;;;;;; apenas insert block
(ACTION_TILE "BT-SAIR" "(DONE_DIALOG 0)")
(SETQ XFIM1 (START_DIALOG))
;
(IF (= XFIM1 0) (SETQ FLAGOK1 nil))
(IF (= XFIM1 1) (AT-AREA-SELECIONAR));;;;;;;;;;;;; não trabalhar no sistema de seleção
(IF (= XFIM1 2) (AT-AREA-INDICARPON));;;;;;;;;;;;;;;;apenas insert block
)
;
(PRINC)
)
;...............................................................................
(DEFUN AT-AREA-SELECIONAR ()
;
(COMMAND "_UNDO" "_BEGIN")
(IF SALVA (SALVA (LIST "OSMODE" "CLAYER" "TEXTSTYLE")))
(SETVAR "OSMODE" 0)
;(SETQ FLAGOK1 nil)
;(IF (NOT FLAGAA)(ALERT "\nSELECIONE UM POLIGONO!"))(SETQ FLAGIJ T)
;
(SETQ VVBL "STANDARD-AREA")
(VERIFICA-VVBL VVBL)
;
(SETQ FLAGX T)
(SETQ ENTS1 (ENTSEL"\n>>Selecione um poligono <ENTER=Fim>: "))
(WHILE FLAGX
(SETQ FLAGA T)
(WHILE FLAGA
(IF (NOT ENTS1) (PROGN (SETQ FLAGA nil)(SETQ FLAGX nil)))
(IF FLAGX
(PROGN
(SETQ ENT1 (CAR ENTS1))
(SETQ PT1 (CADR ENTS1))
(SETQ LL1 (ENTGET ENT1))
(SETQ TIPO (CDR (ASSOC 0 LL1)))
(IF (OR (= TIPO "LWPOLYLINE")(= TIPO "REGION"))
(SETQ FLAGA nil)
(ALERT "OBJETO SELECIONADO NÃO É UM POLIGONO!")
)
)
)
)
;
(IF FLAGX
(PROGN
(COMMAND "_AREA" "_O" ENT1)
(SETQ VVAREA (STRCAT (RTOS (GETVAR "AREA") 2 2) ))
(SETQ VCENT (AT-CENTROID ENT1))
(COMMAND "_INSERT" VVBL VCENT ESCALA "" "" VVAREA NIVEPR (NTH (ATOI NLA) LLAREA2) (NTH (ATOI NLR) LLREVE2) )
;
(SETQ ENTS1 (ENTSEL"\n>>Selecione um poligono <ENTER=Fim>: "))
)
)
)
;
(IF RESTAURA (RESTAURA))
(COMMAND "_UNDO" "_END")
;
)
;...............................................................................
(DEFUN AT-AREA-INDICARPON ()
;
(COMMAND "_UNDO" "_BEGIN")
(IF SALVA (SALVA (LIST "OSMODE" "CLAYER" "TEXTSTYLE")))
(SETVAR "OSMODE" 0)
;(SETQ FLAGOK1 nil)
;(IF (NOT FLAGAA)(ALERT "\nSELECIONE UM POLIGONO!"))(SETQ FLAGIJ T);;;;;;;;;;;;;;;;; selecionar uma linha com osnap 100%
;
(SETQ VVBL "STANDARD-AREA");;;;;;;;;;;o novo nome do bloco STANDARD-NIVEL
(VERIFICA-VVBL VVBL)
;
(SETQ FLAGX T)
(SETQ PTSI1 (GETPOINT"\n>>Selecione um Ponto Interno <ENTER=Fim>: "));;;;;;;;;;;;;;;;; selecionar uma linha com osnap 100%
(WHILE FLAGX)
(SETQ FLAGA T)
(WHILE FLAGA
(IF (NOT PTSI1) (PROGN (SETQ FLAGA nil)(SETQ FLAGX nil)))
(IF FLAGX
(PROGN
(SETQ HANX (CDR (ASSOC 5 (ENTGET (ENTLAST)))))
(COMMAND "_-BOUNDARY" PTSI1 "")
(SETQ HANY (CDR (ASSOC 5 (ENTGET (ENTLAST)))))
(IF (= HANX HANY)
(PROGN
(ALERT "*** NÃO FOI POSSIVEL CRIAR UM POLIGONO! ***\nVERIFIQUE SE É UMA AREA FECHADA\nOU CONGELE ALGUMAS CAMADAS QUE POSSAM INTERFERIR!")
(SETQ FLAGX nil)
)
(PROGN
;(COMMAND "_REGION" (ENTLAST) "");;;;;;;;;;;;;;;;; selecionar uma linha com osnap 100%
(SETQ ENTL (ENTLAST));;;;;;;;;;;;;;;;; selecionar uma linha com osnap 100%
(SETQ FLAGA nil);;;;;;;;;;;;;;;;; selecionar uma linha com osnap 100%
)
)
)
)
)
;
(IF FLAGX
(PROGN
(SETQ ENTL (ENTLAST))
(COMMAND "_AREA" "_O" ENTL)
(SETQ VVAREA (STRCAT (RTOS (GETVAR "AREA") 2 2) "m²"));;;;;;;;;;;;;;;;;; não calcular area
(SETQ VCENT (AT-CENTROID ENTL));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;não calcular centroide
(COMMAND "_INSERT" VVBL VCENT ESCALA "" "" VVAREA NIVEPR (NTH (ATOI NLA) LLAREA2) (NTH (ATOI NLR) LLREVE2) ) ;;;não ler revestimento
;
(SETQ PTSI1 (GETPOINT"\n>>Selecione um Ponto Interno <ENTER=Fim>: "));;;;; inserir o bloco com o snap 100%
)
)
)
;
(IF RESTAURA (RESTAURA))
(COMMAND "_UNDO" "_END")
;
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;não calcular centroide
(defun AT-CENTROID ( e / l )
(foreach x (setq e (entget e))
(if (= 10 (car x)) (setq l (cons (cdr x) l)))
)
(
(lambda ( a )
(if (not (equal 0.0 a 1e-8))
(trans
(mapcar '/
(apply 'mapcar
(cons '+
(mapcar
(function
(lambda ( a b )
(
(lambda ( m )
(mapcar
(function
(lambda ( c d ) (* (+ c d) m))
)
a b
)
)
(- (* (car a) (cadr b)) (* (car b) (cadr a)))
)
)
)
l (cons (last l) l)
)
)
)
(list a a)
)
(cdr (assoc 210 e)) 0
)
)
)
(* 3.0
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car a) (cadr b)) (* (car b) (cadr a)))
)
)
l (cons (last l) l)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
