o topografo: autolisps

Para receber minhas DICAS EXCLUSIVAS a Respeito de Legislação, Produtividade, Produção de plantas e Resolução de Problemas em Seu e-mail utilize o botão abaixo para acessar o formulário de inscrição.

O autolisp foi desenvolvido especialmente para o AutoCAD a partir da linguagem lisp, criada por John McCarthy, só quem trabalha rotineiramente com o AutoCAD sabe o quanto que rotinas lisps facilitam o trabalho, já que estas acrescentam novas funcionalidades e ferramentas, desde as mais básicas até as mais complexas.

Acesse aqui o tutorial que ensina a inserir e utilizar rotinas lisp

Principais rotinas para facilitar a sua vida

Copie as que achar interessante, cole no bloco de notas e salve com a terminação .lsp

Rotina para inserir grade de coordenadas no AutoCAD

;|Este es un lisp en formato original, se puede ver el código fuente, la intención, es de que el código fuente 
; pueda ser modificado y adaptado a la necesidad de cada usuario, lo único que siempre se solicita en estos 
; casos es de que siempre se haga referencia al autor del mismo (es decir que no se modifique la autoría del lisp), 
; salvo que este se modifique ampliamente, si se construye un nuevo programa tomando como partes un lisp publicado, 
; se debería de hacer el comentario de que parte del nuevo programa esta basado en el autor original.|; 
 
; Programa descargado desde http://www.construcgeek.com 
; ConstrucGeek 2008 
 
; Crear una malla de coordenadas 
 
(DEFUN C:M4 () 
 
(acet-error-init(list (list "cmdecho" 0 "osmode" 0 "DIMZIN" 1) T )) 
 
(setq osa (getvar "osmode")) 
(setvar "cmdecho" 0) 
 
(SETQ VETN NIL VETE NIL VETMAXN NIL VETMAXE NIL VETM NIL VETDY NIL VETDX NIL) 
(SETQ MALHAE NIL MALHAN NIL) 
(SETQ OP (GETINT "\nIngrese el tipo: 1 - NE , 2 - XY : ")) 
(IF (= OP 1) 
(SETQ ABSC "E=" ORDE "N=") 
(SETQ ABSC "X=" ORDE "Y=") 
) 
(SETQ INTERV (GETINT "\nIntervalo de la malla: ")) 
(SETQ ALT (GETREAL "\nAltura de texto: ")) 
(SETQ PT1 (GETPOINT "\nPrimer vértice del área:")) 
(SETQ PT2 (GETPOINT "\nSegundo vértice del área:")) 
(SETQ PT3 (GETPOINT "\nTercer vértice del área:")) 
(SETQ PT4 (GETPOINT "\nCuarto vértice del área:")) 
(SETQ ANGX (GETINT "\nAngulo de texto del eje X: ")) 
(SETQ ANGY (GETINT "\nAngulo de texto del eje Y: ")) 
(SETQ PTOS (LIST PT1 PT2 PT3 PT4)) 
(COMMAND "_STYLE" "ROMANS" "ROMANS" ALT "1" "0" "_N" "_N" "_N" ) 
 
(SETVAR "OSMODE" 0) 
 
(SETQ ESP " ") 
(SETQ I 0) 
(WHILE (/= I 4) 
(SETQ VETN (CONS (CADR (NTH I PTOS)) VETN)) 
(SETQ VETE (CONS (CAR (NTH I PTOS)) VETE)) 
(SETQ I (+ 1 I)) 
) 
(SETQ VETN (REVERSE VETN) VETE (REVERSE VETE)) 
(SETQ I 0) 
(WHILE (/= I 4) 
(IF (= I 3) (SETQ J 0) (SETQ J (1+ I))) 
(SETQ VETMAXN (CONS (MAX (NTH I VETN) (NTH J VETN)) VETMAXN)) 
(SETQ VETMAXE (CONS (MAX (NTH I VETE) (NTH J VETE)) VETMAXE)) 
(SETQ I (+ 1 I)) 
) 
(SETQ VETMAXN (CONS (MAX (NTH 3 VETMAXN) (NTH 1 VETMAXN)) VETMAXN)) 
(SETQ VETMAXE (CONS (MAX (NTH 3 VETMAXE) (NTH 1 VETMAXE)) VETMAXE)) 
(SETQ VETMAXN (REVERSE VETMAXN) VETMAXE (REVERSE VETMAXE)) 
(SETQ I 0) 
(WHILE (/= I 4) 
(IF (= I 3) (SETQ J 0) (SETQ J (1+ I))) 
(SETQ VETDY (CONS (- (NTH J VETN) (NTH I VETN)) VETDY)) 
(SETQ VETDX (CONS (- (NTH J VETE) (NTH I VETE)) VETDX)) 
(SETQ I (+ 1 I)) 
) 
(SETQ VETDY (REVERSE VETDY) VETDX (REVERSE VETDX)) 
(SETQ I 0) 
(WHILE (/= I 4) 
(SETQ VARDX (NTH I VETDX)) 
(IF (= VARDX 0.0) 
(SETQ VARDX 0.000001) 
) 
; (SETQ VETM (CONS (/ (NTH I VETDY) (NTH I VETDX)) VETM)) 
(SETQ VETM (CONS (/ (NTH I VETDY) VARDX) VETM)) 
(SETQ I (+ 1 I)) 
) 
(SETQ VETM (REVERSE VETM)) 
(SETQ I 0) 
(WHILE (/= I 4) 
(SETQ IN INTERV) 
(IF (= I 3) (SETQ J 0) (SETQ J (1+ I))) 
(SETQ FLAG 0) 
(WHILE (= FLAG 0) 
(SETQ X (* (FIX (/ (+ (MIN (NTH I VETE) (NTH J VETE)) IN) INTERV)) INTERV)) 
(IF (> X (NTH I VETMAXE)) 
(SETQ FLAG 1) 
(PROGN 
(SETQ Y (+ (NTH I VETN) (* (NTH I VETM) (- X (NTH I VETE))))) 
(SETQ PT (LIST X Y)) 
(SETQ MALHAE (CONS PT MALHAE)) 
(SETQ IN (+ IN INTERV)) 
) 
) 
) 
(SETQ I (+ 1 I)) 
) 
(SETQ MALHAE (REVERSE MALHAE)) 
(SETQ QUANTI (LENGTH MALHAE)) 
(SETQ I 0) 
(IF (= ANGX 90) (SETQ ACR (* (/ ALT 2) -1)) (SETQ ACR (/ ALT 2))) 
(SETQ CONTAD 1) 
(WHILE (<= CONTAD (/ QUANTI 2))
 (SETQ J (1+ I))
 (SETQ X (CAR (NTH I MALHAE)))
 (WHILE (/= X (CAR(NTH J MALHAE)))
 (SETQ J (+ 1 J))
 )
 (COMMAND "_LINE" (NTH I MALHAE) (NTH J MALHAE) "")
; (IF (= ANGX 90) (SETQ V1 "R" V2 "") (SETQ V1 "" V2 "R"))
 (SETQ CY (MAX (CADR (NTH I MALHAE)) (CADR (NTH J MALHAE))))
 (SETQ PX (LIST (+ (CAR (NTH I MALHAE)) ACR) CY))
 (IF (= ANGX 90) 
 (COMMAND "_TEXT" "_R" PX ANGX (STRCAT ABSC (rtos (CAR(NTH J MALHAE)) 2 0) ESP))
 (COMMAND "_TEXT" PX ANGX (STRCAT ESP ABSC (rtos (CAR(NTH J MALHAE)) 2 0)))
 )
 (SETQ CY (MIN (CADR (NTH I MALHAE)) (CADR (NTH J MALHAE))))
 (SETQ PX (LIST (+ (CAR (NTH I MALHAE)) ACR) CY))
 (IF (= ANGX 90) 
 (COMMAND "_TEXT" PX ANGX (STRCAT ESP ABSC (rtos (CAR(NTH J MALHAE)) 2 0)))
 (COMMAND "_TEXT" "_R" PX ANGX (STRCAT ABSC (rtos (CAR(NTH J MALHAE)) 2 0) ESP))
 )
 (SETQ AUX1 NIL AUX2 NIL AUX NIL)
 (SETQ AUX1 (MEMBER (NTH (1+ I) MALHAE) MALHAE))
 (IF (/= I 0)
 (PROGN
 (SETQ PAR (NTH (1- I) MALHAE))
 (SETQ AUX (REVERSE MALHAE))
 (SETQ AUX2 (REVERSE (MEMBER PAR AUX)))
 (SETQ MALHAE (APPEND AUX2 AUX1))
 )
 (PROGN 
 (SETQ MALHAE AUX1)
 )
 )
 (SETQ AUX1 NIL AUX2 NIL AUX NIL)
 (IF (= J 1)
 (SETQ MALHAE (MEMBER (NTH J MALHAE) MALHAE))
 (PROGN
 (SETQ J (1- J))
 (IF (< (1+ J) (LENGTH MALHAE))
 (PROGN
 (SETQ AUX1 (MEMBER (NTH (1+ J) MALHAE) MALHAE))
 (SETQ PAR (NTH (1- J) MALHAE))
 (SETQ AUX (REVERSE MALHAE))
 (SETQ AUX2 (REVERSE (MEMBER PAR AUX)))
 (SETQ MALHAE (APPEND AUX2 AUX1))
 )
 )
 )
 )
 (SETQ CONTAD (1+ CONTAD))
 )
 (SETQ I 0)
 (WHILE (/= I 4)
 (SETQ IN INTERV)
 (IF (= I 3) (SETQ J 0) (SETQ J (1+ I)))
 (SETQ FLAG 0)
 (WHILE (= FLAG 0)
 (SETQ Y (* (FIX (/ (+ (MIN (NTH I VETN) (NTH J VETN)) IN) INTERV)) INTERV))
 (IF (> Y (NTH I VETMAXN)) 
(SETQ FLAG 1) 
(PROGN 
(SETQ X (/ (+ (- (* (NTH I VETM) (NTH I VETE)) (NTH I VETN)) Y) (NTH I VETM))) 
(SETQ PT (LIST X Y)) 
(SETQ MALHAN (CONS PT MALHAN)) 
(SETQ IN (+ IN INTERV)) 
) 
) 
) 
(SETQ I (+ 1 I)) 
) 
(SETQ MALHAN (REVERSE MALHAN)) 
(SETQ VERI MALHAN) 
(SETQ QUANTI (LENGTH MALHAN)) 
(SETQ I 0) 
(IF (= ANGY 180) (SETQ ACR (* (/ ALT 2) -1)) (SETQ ACR (/ ALT 2))) 
(SETQ CONTAD 1) 
(WHILE (<= CONTAD (/ QUANTI 2))
 (SETQ J (1+ I))
 (SETQ Y (CADR (NTH I MALHAN)))
 (WHILE (/= Y (CADR(NTH J MALHAN)))
 (SETQ J (+ 1 J))
 )
 (COMMAND "_LINE" (NTH I MALHAN) (NTH J MALHAN) "")
 (SETQ CX (MAX (CAR (NTH I MALHAN)) (CAR (NTH J MALHAN))))
 (SETQ PY (LIST CX (+ (CADR (NTH I MALHAN)) ACR)))
; (COMMAND "TEXT" "R" PY ANGY (strcat ORDE (rtos (CADR(NTH J MALHAN)) 2 0)))
 (IF (= ANGY 180)
 (COMMAND "_TEXT" PY ANGY (strcat ESP ORDE (rtos (CADR(NTH J MALHAN)) 2 0)))
 (COMMAND "_TEXT" "_R" PY ANGY (strcat ORDE (rtos (CADR(NTH J MALHAN)) 2 0) ESP))
 )
 (SETQ CX (MIN (CAR (NTH I MALHAN)) (CAR (NTH J MALHAN))))
 (SETQ PY (LIST CX (+ (CADR (NTH I MALHAN)) ACR)))
; (COMMAND "TEXT" PY ANGY (strcat ORDE (rtos (CADR(NTH J MALHAN)) 2 0)))
 (IF (= ANGY 180)
 (COMMAND "_TEXT" "_R" PY ANGY (strcat ORDE (rtos (CADR(NTH J MALHAN)) 2 0) ESP))
 (COMMAND "_TEXT" PY ANGY (strcat ESP ORDE (rtos (CADR(NTH J MALHAN)) 2 0)))
 )
 (SETQ AUX1 NIL AUX2 NIL AUX NIL)
 (SETQ AUX1 (MEMBER (NTH (1+ I) MALHAN) MALHAN))
 (IF (/= I 0)
 (PROGN
 (SETQ PAR (NTH (1- I) MALHAN))
 (SETQ AUX (REVERSE MALHAN))
 (SETQ AUX2 (REVERSE (MEMBER PAR AUX)))
 (SETQ MALHAN (APPEND AUX2 AUX1))
 )
 (PROGN 
 (SETQ MALHAN AUX1)
 )
 )
 (SETQ AUX1 NIL AUX2 NIL AUX NIL)
 (IF (= J 1)
 (SETQ MALHAN (MEMBER (NTH J MALHAN) MALHAN))
 (PROGN
 (SETQ J (1- J))
 (IF (< (1+ J) (LENGTH MALHAN))
 (PROGN
 (SETQ AUX1 (MEMBER (NTH (1+ J) MALHAN) MALHAN))
 (SETQ PAR (NTH (1- J) MALHAN))
 (SETQ AUX (REVERSE MALHAN))
 (SETQ AUX2 (REVERSE (MEMBER PAR AUX)))
 (SETQ MALHAN (APPEND AUX2 AUX1))
 )
 )
 )
 )
 (SETQ CONTAD (1+ CONTAD))
 )
 
 (acet-error-restore)
 
 (SETVAR "osmode" OSA)
 (setvar "cmdecho" 1)
 (setvar "modemacro" "http://www.construcgeek.com/")
 
 (princ)
)

rotina para rodar texto com o eixo no ponto intermediário da diagonal

(defun C:ROTXT (/   AERR     ADECH     AOSMD SSET SSLEN   ANGROT    SSTEMP    ENTTMP TXTDIA PTDIAG01  PTDIAG02  PTPIVOT )  (command "_undo" "begin") (setq AERR  *error* ADECH (getvar "cmdecho") AOSMD (getvar "OSMODE") ) (setvar "cmdecho" 0) (setvar "OSMODE" 0) (princ "\n Seleccione textos a rodar \n") (setq SSET  (ssget '((0 . "TEXT"))) SSLEN (sslength SSET) ) (princ "\n Digite ângulo de rotação: ") (setq ANGROT (getreal)) (terpri) (if (> SSLEN 100) (princ "\n A rodar...\n") ) ;(command "_ucs" "s" "TempBase") (while (> SSLEN 0) (setq SSTEMP   (ssname SSET (setq SSLEN (1- SSLEN))) ENTTMP   (entget SSTEMP) TXTDIAG  (textbox ENTTMP) PTDIAG01 (car TXTDIAG) PTDIAG02 (cadr TXTDIAG) PTPIVOT  (polar PTDIAG01 (angle PTDIAG01 PTDIAG02) (/ (distance PTDIAG01 PTDIAG02) 2) ) ) ;(command "_ucs" "object" SSTEMP) (command "_rotate" SSTEMP "" PTPIVOT ANGROT) )     ;while ;(command "_ucs" "r" "TempBase") ;(command "_ucs" "d" "TempBase") (setvar "cmdecho" ADECH) (setvar "OSMODE" AOSMD) (command "_undo" "end")  )  ;;; ;;; ;;;  (defun *error* (msg)  (setq *error* AERR) (setvar "cmdecho" ADECH) (setvar "OSMODE" AOSMD) (command "_undo" "end") (princ (strcat "  Aplicação interrompida com erro: " msg)) ) (terpri) (princ "  Inicie aplicação digitando ROTXT  ") (terpri)

rotina para converter ponto em texto

(defun C:CPT (/ AOSMD ADECH ADZIN VALLPRC UNPRC TEXTST ENTST STHIGT TEXTSZ TEMPS CORDX CORDY CORDZ TXCORDZ PONTO ) (command "_.undo" "begin") (setq AERR *error*) (setq AOSMD (getvar "osmode") ADECH (getvar "cmdecho") ADZIN (getvar "dimzin") ) (setvar "cmdecho" 0) (setvar "dimzin" 0) (setq VALLPRC (getvar "luprec")) (princ "\n»» Seleccione pontos:\n") (setq SSET (ssget '((0 . "POINT")))) (setvar "osmode" 0) (if SSET (progn (terpri) (princ "\n»» Quantas casas decimais? (0/8) ") (princ "<") (princ="" vallprc)="" (princ="" "="">") (setq UNPRC (getint)) (if (= UNPRC nil) (setq UNPRC VALLPRC) ) (setq TEXTST (getvar "TEXTSTYLE")) (setq ENTST (tblsearch "style" TEXTST)) (setq STHIGT (cdr (assoc 40 ENTST))) (PRINC STHIGT) (setq OSM (getvar "osmode")) (if (= STHIGT 0.0) (progn (princ "\n»» Qual a altura do texto? ") (setq TEXTSZ (getdist)) ) ) (setq SSLEN (sslength SSET)) (while (> SSLEN 0) (setq TEMPS (ssname SSET (setq SSLEN (1- SSLEN)))) (setq CORDX (nth 1 (assoc 10 (entget TEMPS)))) (setq CORDY (nth 2 (assoc 10 (entget TEMPS)))) (setq CORDZ (nth 3 (assoc 10 (entget TEMPS)))) (setq TXCORDZ (rtos CORDZ 2 UNPRC)) (setq PONTO (list CORDX CORDY 0.0)) (if (> STHIGT 0.0) (command "text" PONTO 00.00 TXCORDZ) (command "text" PONTO TEXTSZ 00.00 TXCORDZ) ) ) ) (princ "\n»» Nenhum ponto seleccionado!") ) (setvar "osmode" AOSMD) (setvar "dimzin" ADZIN) (command "_.undo" "end") ) ;;; ;;; ;;; (defun *error* (msg) (setq *error* AERR) (setvar "cmdecho" ADECH) (setvar "osmode" AOSMD) (setvar "dimzin" ADZIN) (command "_.undo" "end") (princ (strcat "»» Aplicação interrompida com erro: " msg)) ) (terpri) (princ "\n»» Inicie aplicação digitando CPT \n") Rotina para registrar coordenadas de pontos em ficheiro de texto (defun c:RCP (/ ACMDCH ADZIN VALLPRC UNPRC SSET NMFILE FILETX VIRG SSLEN TEMPS CORDX CORDY CORDZ TXCORDX TXCORDY TXCORDZ ) (defun SETVRS () (setq ACMDCH (getvar "cmdecho")) (setvar "cmdecho" 0) (setq ADZIN (getvar "dimzin")) (setvar "dimzin" 0) (setq VALLPRC (getvar "luprec")) (command "_.undo" "begin") (setq AERR *error*) ) (defun RESETVRS () (setq *error* AERR) (setvar "dimzin" ADZIN) (command "_.undo" "end") (setvar "cmdecho" ACMDCH) ) (SETVRS) (princ "\n»» Quantas casas decimais? (0/8) ") (princ "<") (princ="" vallprc)="" (princ="" "="">") (setq UNPRC (getint)) (princ "\n»» Seleccione pontos:\n") (setq SSET (ssget '((0 . "POINT")))) (if SSET (progn (if (= UNPRC nil) (setq UNPRC VALLPRC) ) (setq NMFILE (getfiled "Ficheiro para registo das coordenadas" "" "txt" 1 ) FILETX (open NMFILE "a") VIRG "," SSLEN (sslength SSET) ) (while (> SSLEN 0) (setq TEMPS (ssname SSET (setq SSLEN (1- SSLEN))) CORDX (nth 1 (assoc 10 (entget TEMPS))) CORDY (nth 2 (assoc 10 (entget TEMPS))) CORDZ (nth 3 (assoc 10 (entget TEMPS))) TXCORDX (rtos CORDX 2 UNPRC) TXCORDY (rtos CORDY 2 UNPRC) TXCORDZ (rtos CORDZ 2 UNPRC) ) (write-line (strcat "" TXCORDX "" VIRG "" TXCORDY "" VIRG "" TXCORDZ "") FILETX ) ) (close FILETX) ) (princ "\n»» Nenhum ponto seleccionado... \n") ) (RESETVRS) ) ;;; ;;; ;;; (defun *error* (msg) (setq *error* AERR) (if FILETX (close FILETX) ) (setvar "cmdecho" ACMDCH) (setvar "dimzin" ADZIN) (command "_.undo" "end") (princ (strcat "»» Aplicação interrompida com erro: " msg)) ) (terpri) (princ "\n»» Inicie aplicação digitando RCP \n") Rotina que altera o tamanho do texto do desenho (defun c:tamedit() (setvar "cmdecho" 0) (setq texto(entget(car(entsel "\nSelecione o texto:")))) (setq te1(cdr(assoc 40 texto))) (setq te(rtos te1 2 2)) (setq op(cdr(assoc 0 texto))) (if (= op "TEXT") (progn (setq DCL(load_dialog "tamedit.dcl")) (new_dialog "tamedit" DCL) (set_tile "texto" te) (mode_tile "texto" 2) (action_tile "accept" "(setq op 1)(done_dialog)") (action_tile "cancel" "(setq op nil)(done_dialog)") (action_tile "texto" "(setq tex $value)()") (start_dialog) (unload_dialog DCL) (if (= op 1) (progn (setq tex(atof tex)) (setq ede(subst (cons 40 tex)(assoc 40 texto) texto)) (entmod ede))) (setvar "cmdecho" 1))) ;;;;;;;;; (if (= op "MTEXT") (progn (setq DCL(load_dialog "tamedit.dcl")) (new_dialog "tamedit" DCL) (set_tile "texto" te) (mode_tile "texto" 2) (action_tile "accept" "(setq op 1)(done_dialog)") (action_tile "cancel" "(setq op nil)(done_dialog)") (action_tile "texto" "(setq tex $value)()") (start_dialog) (unload_dialog DCL) (if (= op 1) (progn (setq tex(atof tex)) (setq ede(subst (cons 40 tex)(assoc 40 texto) texto)) (entmod ede))) (setvar "cmdecho" 1))) ) </")></")>

Rotina que cria Múltiplos OFFSET

Rotina para cálculo de área

Rotina que cria um circulo com linha ao centro

Rotina para somar áreas com a possibilidade de colocar o resultado com o texto em M²

(defun C:SOMAREA2 (/    CMDCH    DMZN     LUPRC    ARSTOTAL TERM TXTOTAL  CTXT     GAR      SSLEN    TPNAM    ENTGT ENTTPO   ARTPNAM  ARSTOTAL TXSTOTAL TEXTST   TEXTSZ ENTST    STHIGT   OSMD     PTINS    GTXTF    TXTNOV ENTNAM   ENTGTB   TXTOLD )   (command "_.undo" "begin") (setq CMDCH (getvar "cmdecho")) (setvar "cmdecho" 0) (setq DMZN (getvar "dimzin")) (setvar "dimzin" 0) (setq LUPRC  (getvar "luprec") ARSTOTAL 0.0 TERM  0 ) (MAREA) (while (/= TERM nil) (progn (MAREA) ) ) (setq TXTOTAL (strcat "A=" (rtos ARSTOTAL 2 LUPRC) "m2")) (initget "Criar Substituir ") (setq CTXT (getkword "»» [C] Criar texto novo / [S] Substituir texto existente / [Enter] Terminar:" ) ) (if (= CTXT "Criar") (COLRESLC) ) (if (= CTXT "Substituir") (COLRESLS) ) (setvar "dimzin" DMZN) (setvar "cmdecho" CMDCH) (command "_.undo" "end") (princ "\n»» Total = ") (princ (rtos ARSTOTAL 2 LUPRC)) (terpri)  )  ;;; ;;; ;;;  (defun MAREA ()  (princ "\n»» Seleccione entidades a somar:\n") (setq GAR (ssget)) (if GAR (progn (setq SSLEN (sslength GAR)) (while (> SSLEN 0) (setq TPNAM  (ssname GAR (setq SSLEN (1- SSLEN))) ENTGT  (entget TPNAM) ENTTPO (cdr (assoc 0 ENTGT)) ) (if (or (equal ENTTPO "REGION") (equal ENTTPO "3DSOLID") (equal ENTTPO "POLYLINE") (equal ENTTPO "LWPOLYLINE") (equal ENTTPO "CIRCLE") (equal ENTTPO "ARC") (equal ENTTPO "SPLINE") (equal ENTTPO "ELLIPSE") ) (progn (command "_.area" "o" TPNAM) (setq ARTPNAM  (getvar "AREA") ARSTOTAL (+ ARTPNAM ARSTOTAL) ) ) ) ) ) (princ "\n»» Nenhuma entidade seleccionada! \n") ) (setq TXSTOTAL (strcat "A=" (rtos ARSTOTAL 2 LUPRC) "m2")) (princ "\n»» Sub Total = ") (princ (rtos ARSTOTAL 2 LUPRC)) (terpri) (initget "Adicionar") (setq TERM (getkword "»» [A] Adicionar outras entidades / [Enter] Terminar selecção:" ) ) )  ;;; ;;; ;;;  (defun COLRESLC ()  (setq TEXTST (getvar "TEXTSTYLE") TEXTSZ (getvar "TEXTSIZE") ENTST  (tblsearch "style" TEXTST) STHIGT (cdr (assoc 40 ENTST)) OSMD   (getvar "OSMODE") ) (setvar "OSMODE" 0) (princ "\n»» Seleccione ponto de inserção do texto:" ) (setq PTINS (getpoint)) (setvar "OSMODE" OSMD)  (if (> STHIGT 0.0) (command "_.text" "j" "mr" PTINS 00.00 TXSTOTAL) ) (if (= STHIGT 0.0) (command "_.text" "j" "mr" PTINS TEXTSZ 00.00 TXSTOTAL) ) )  ;;; ;;; ;;;   (defun COLRESLS ()  (setq TEXTST (getvar "TEXTSTYLE") TEXTSZ (getvar "TEXTSIZE") ENTST  (tblsearch "style" TEXTST) STHIGT (cdr (assoc 40 ENTST)) OSMD   (getvar "OSMODE") ) (setvar "OSMODE" 0) (princ "\n»» Seleccione texto a substituir:" ) (setvar "OSMODE" OSMD) (setq GTXTF  (entsel) TXTNOV (cons 1 TXSTOTAL) ENTNAM (car GTXTF) ENTGTB (entget ENTNAM) TXTOLD (assoc 1 ENTGTB) ) (entmod (subst TXTNOV TXTOLD ENTGTB)) (entupd ENTNAM) )

Rotina para Colocar as Coordenadas nos Pontos Desejados

(PRINC "\nChamada de Coordenadas - Por: Pedro Maia dos Santos Filho " ) (PRINC "\nDigite NE e tecle para começar...") (princ) (DEFUN c:ne (/ var-r5 coratu osmatu pto pto1 ptx stx pty sty p2 p3 p4 ;;;tamx tamy tam ) (SETVAR "CMDECHO" 0) (IF (= (GETVAR "USERR5") 0.0) (PROGN (INITGET 7) (SETQ var-r5 (GETREAL "\n-> Entre com o valor de VAR-R5 : ")) (SETVAR "USERR5" var-r5) ) (SETQ var-r5 (GETVAR "USERR5")) ) (SETQ coratu (GETVAR "CECOLOR") osmatu (GETVAR "OSMODE") ) (WHILE (SETQ pto (GETPOINT "\n-> Selecione o ponto a cotar : ")) (IF (SETQ pto1 (GETPOINT pto "\n-> Selecione o ponto de chamada : ")) (PROGN (SETQ ptx (CAR pto) stx (RTOS ptx 2 4) pty (CADR pto) sty (RTOS pty 2 4) ) (IF (<= (car="" pto)="" (car="" pto1))="" (setq="" p2="" (list="" (+="" (car="" pto1)="" (/="" 28.0="" var-r5))="" (cadr="" pto1)="" (caddr="" pto1)="" )="" p3="" (list="" (+="" (car="" pto1)="" (/="" 1.0="" var-r5))="" (+="" (cadr="" pto1)="" (/="" 1.0="" var-r5))="" (caddr="" pto1)="" )="" p4="" (list="" (+="" (car="" pto1)="" (/="" 1.0="" var-r5))="" (-="" (cadr="" pto1)="" (/="" 3.0="" var-r5))="" (caddr="" pto1)="" )="" )="" (setq="" p2="" (list="" (-="" (car="" pto1)="" (/="" 28.0="" var-r5))="" (cadr="" pto1)="" (caddr="" pto1)="" )="" p3="" (list="" (+="" (car="" p2)="" (/="" 1.0="" var-r5))="" (+="" (cadr="" p2)="" (/="" 1.0="" var-r5))="" (caddr="" p2)="" )="" p4="" (list="" (+="" (car="" p2)="" (/="" 1.0="" var-r5))="" (-="" (cadr="" p2)="" (/="" 3.0="" var-r5))="" (caddr="" p2)="" )="" )="" )="" ;;;="" (setq="" tamx="" (strlen="" stx)="" ;;;="" tamy="" (strlen="" sty)="" ;;;="" )="" ;;;="" (if=""></=>< tamx="" tamy)="" ;;;="" (setq="" tam="" tamy)="" ;;;="" (setq="" tam="" tamx)="" ;;;="" )="" (setq="" tex="" (strcat="" "n=" sty)
;; (STR sty tam))
tey (STRCAT " e=" stx)
;; (STR stx tam))
)
(SETVAR " cecolor"="" "2")="" (setvar="" "osmode"="" 0)="" ;;(command="" "text"="" p3="" (/="" 2.03="" var-r5)="" "90"="" tex)="" (entmake="" (list="" (cons="" 0="" "text")="" (cons="" 1="" tex)="" (cons="" 10="" p3)="" (cons="" 40="" (/="" 2.03="" var-r5))="" (cons="" 50="" 0.0)="" )="" )="" ;;(command="" "text"="" p4="" (/="" 2.03="" var-r5)="" "90"="" tey)="" (entmake="" (list="" (cons="" 0="" "text")="" (cons="" 1="" tey)="" (cons="" 10="" p4)="" (cons="" 40="" (/="" 2.03="" var-r5))="" (cons="" 50="" 0.0)="" )="" )="" (command="" "_.pline"="" pto="" pto1="" p2="" "")="" (setvar="" "cecolor"="" coratu)="" (setvar="" "osmode"="" osmatu)="" )="" nil="" )="" nil="" )="" (princ="" "\n-=""> Encerrado...") (PRINC) )

Rotina que cria talude a partir de linha auxiliar

(defun c:talude(/ baseline lbaseline lineaux llineaux distancia nivel c lb ptb1 ptb2 distaux ang dis d k ) (setq nivel "")(while (not baseline)(setq baseline (car(entsel "\nSelecione a linha base :"))) (if (not baseline)(prompt "\nNenhuma polilinha foi selecionada!!!")))(while (not lineaux) (setq lineaux (car(entsel "\nSelecione a linha auxiliar :")))(if (not lineaux)(prompt "\nNenhuma polilinha foi selecionada!!!")) )(while (= nivel "")(setq nivel (getstring "\nDigite o layer do talude a ser inserido: ")) (if (not nivel)(prompt "\nLayer invalido!!!")))(while (not distancia)(setq distancia (getdist "\nEntre com a distƒncia entre os tra‡os: ")) (if (not distancia)(prompt "\nDistancia invalida!!!")) )(if (/= "POLYLINE" (cdr (assoc 0 (entget baseline)))) (progn(prompt "\nERRO:O objeto selecionado nao e uma polilinha!!!")(terpri)(exit)))(if (/= "POLYLINE" (cdr (assoc 0 (entget lineaux)))) (progn (prompt "\nERRO:O objeto selecionado nao e uma polilinha!!!")(terpri)(exit))) (setq lbaseline (geralist baseline) llineaux (geralist lineaux) larg (dismax baseline lineaux) c 0 k T)(setq lb (nth c lbaseline)dis (caddr lb)distaux dis d 0)(prompt "\nDesenhando talude") (while lb(prompt ".")(setq ptb1 (car lb)ptb2 (cadr lb) ang (cadddr lb)d (+ d (- dis (- distaux distancia))) pt1 (polar ptb1 ang d) pt2 (findpt pt1 ang larg llineaux))(deslin pt1 pt2 nivel k)(setq dis (- distaux distancia) distaux dis k (not k))(while (< distaux="" distancia)(prompt="" ".")(setq="" c="" (1+="" c)="" d="" 0="" lb="" (nth="" c="" lbaseline)="" )(if="" lb="" (setq="" dis="" (caddr="" lb)="" distaux="" (+="" distaux="" dis))(setq="" distaux="" distancia))))(prompt="" "\nprograma="" finalizado.")="" (princ))="" (defun="" findpt(ptt1="" angulo="" compr="" llent)="" (setq="" inte="" nill="" r="" 0="" la="" (nth="" r="" llent)="" lres="" (append)="" )="" (while="" la="" (setq="" pta1="" (car="" la)="" pta2="" (cadr="" la)="" ptt2="" (polar="" ptt1="" (+="" angulo="" 1.5708)="" compr)="" inte="" (inters="" pta1="" pta2="" ptt1="" ptt2)="" )="" (if="" (not="" inte)="" (setq="" ptt2="" (polar="" ptt1="" (+="" angulo="" 4.71239)="" compr)="" inte="" (inters="" pta1="" pta2="" ptt1="" ptt2)="" )="" )="" (if="" inte="" (setq="" lres="" (append="" lres="" (list="" inte))))="" (setq="" r="" (1+="" r)="" la="" (nth="" r="" llent)="" )="" )="" (if="" (="(length" lres)="" 0)="" (setq="" res="" (polar="" ptt1="" (+="" angulo="" 1.5708)="" distancia))="" (setq="" res="" (menordist="" ptt1="" lres="" compr))="" )="" )="" (defun="" menordist(="" pt="" listar="" maxi);/="" menor="" dista="" b="" pto)="" (setq="" menor="" maxi="" b="" 0="" )="" (while="">< b="" (length="" listar))="" (setq="" pto="" (nth="" b="" listar))="" (setq="" dista="" (distance="" pt="" pto))="" (if="">< dista="" menor)(setq="" menor="" dista="" ptmenor="" pto))="" (setq="" b="" (1+="" b))="" )="" (setq="" ptmenor="" ptmenor)="" )="" (defun="" geralist="" (entn="" lista="" vert1="" vert2="" flag="" pt1="" pt2="" dis="" ang)="" (setq="" lista="" (append)="" vert1="" (entnext="" entn)="" vert2="" (entnext="" vert1)="" flag="" (cdr="" (assoc="" 0="" (entget="" vert2)))="" )="" (prompt="" "\nprocessando="" vertices="" das="" linhas.")="" (while="" (/="flag" "seqend")="" (setq="" pt1="" (cdr="" (assoc="" 10="" (entget="" vert1)))="" pt2="" (cdr="" (assoc="" 10="" (entget="" vert2)))="" dis="" (distance="" pt1="" pt2)="" ang="" (angle="" pt1="" pt2)="" lista="" (append="" lista="" (list="" (list="" pt1="" pt2="" dis="" ang)))="" vert1="" vert2="" vert2="" (entnext="" vert1)="" flag="" (cdr="" (assoc="" 0="" (entget="" vert2)))="" )="" (prompt="" ".")="" )="" (setq="" lista="" lista)="" )="" (defun="" dismax(ebas="" eaux="" bas="" lbas="" vbas="" laux="" aux="" vaux="" flag="" d="" maiord)(setq="" maiord="" 0="" bas="" (entnext="" ebas)="" aux="" (entnext="" eaux)="" lbas="" (entget="" bas)="" laux="" (entget="" aux)="" vbas="" (cdr="" (assoc="" 10="" lbas))="" flag="" (cdr="" (assoc="" 0="" laux))="" )="" (while="" (/="flag" "seqend")="" (setq="" vaux="" (cdr="" (assoc="" 10="" laux))="" d="" (distance="" vbas="" vaux)="" )="" (if="" (=""> d maiord) (setq maiord d)) (setq aux (entnext aux) laux (entget aux) flag (cdr (assoc 0 laux)) ) ) (setq maiord maiord) )(defun deslin(p1 p2 la t) (if (not la) (setq la (getvar "CLAYER"))) (if (not t) (setq p2 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2))) ) (entmake (list (cons 0 "LINE") (cons 8 la) (list 10 (car p1) (cadr p1) (caddr p1)) (list 11 (car p2) (cadr p2) (caddr p2)) ) ) ) (defun *error* (msg) (princ "ERRO: ") (princ) (terpri) )

desenhar um ponto em cada vértice de uma polilinha

(defun C:DPPOL (/   AERR     AOSMD     ADECH SGPOLY NUMOBJ   NAMENT    ENTGT     TIPENT ENPOLYA TSEXTRA   SSLENP    VALPOLY   FIRSTEL PTZVERT PTVERTICE ENPOLYB   VERTIC    TESSPL TSEXTRB ENVERTB   TSVCONT   PTVERTICE TEMPA VERTIC TESTVER   VERTIC )  (command "_.undo" "begin") (setq AERR *error*) (setq AOSMD (getvar "osmode") ADECH (getvar "cmdecho") ) (setvar "cmdecho" 0) (princ "\n»» Seleccione Polyline(s):\n") (setq SGPOLY (ssget)) (if SGPOLY (progn (setq NUMOBJ (sslength SGPOLY)) (while (> NUMOBJ 0) (setq NAMENT (ssname SGPOLY (setq NUMOBJ (1- NUMOBJ))) ENTGT  (entget NAMENT) TIPENT (cdr (assoc 0 ENTGT)) ) (if (equal TIPENT "LWPOLYLINE") (DFLWPOLY) ) (if (equal TIPENT "POLYLINE") (DFPOLY) ) ) ) (princ "\n»» Nenhuma entidade seleccionada!\n") ) (command "_.undo" "end") )  ;;; ;;; ;;;  (defun DFLWPOLY ()  (setq ENPOLYA (entget NAMENT) TSEXTRA (car (cdr (assoc 210 ENPOLYA))) ) (if (= TSEXTRA 0.0) (progn (setvar "osmode" 0) (setq SSLENP (length ENPOLYA)) (while (> SSLENP 0) (setq SSLENP  (1- SSLENP) VALPOLY (nth SSLENP ENPOLYA) FIRSTEL (car VALPOLY) PTZVERT (cdr (assoc 38 ENPOLYA)) ) (if (= FIRSTEL 10) (progn (setq PTVERTICE (list (nth 1 VALPOLY) (nth 2 VALPOLY) (cdr (assoc 38 ENPOLYA)) ) ) (command "_.point" PTVERTICE) ) ) ) (setvar "osmode" AOSMD) ) ) )  ;;; ;;; ;;;  (defun DFPOLY ()  (setq ENPOLYB (entget NAMENT) VERTIC (entnext NAMENT) TESSPL (cdr (assoc 70 ENPOLYB)) TSEXTRB (car (cdr (assoc 210 ENPOLYB))) ) (if (= TSEXTRB 0.0) (progn (setvar "osmode" 0) (while VERTIC (setq ENVERTB (entget VERTIC) TSVCONT (cdr (assoc 70 ENVERTB)) ) (if (/= TSVCONT 16) (progn (setq PTVERTICE (cdr (assoc 10 ENVERTB))) (command "_.point" PTVERTICE) ) ) (setq TEMPA   VERTIC VERTIC  (entnext TEMPA) TESTVER (cdr (assoc 0 ENVERTB)) ) (if (/= TESTVER "VERTEX") (setq VERTIC nil) ) ) (setvar "osmode" AOSMD) ) ) )  ;;; ;;; ;;;  (defun *error* (msg)  (setq *error* AERR) (setvar "cmdecho" ADECH) (setvar "osmode" AOSMD) (command "_.undo" "end") (princ (strcat "»» Aplicação interrompida com erro: " msg)) )  ;;; ;;; ;;;  (terpri) (princ "\n»» Inicie aplicação digitando DPPOL \n")

CONHEÇA NOSSOS CURSOS

Possuímos 2 videocursos incríveis voltados para a confecção de plantas para Topografia cadastral e para a transformação de dados, além do manual do Topógrafo, a mais completo manual produzido no território nacional com conceitos e passos a passo sobre a utilização de instrumentos e confecção de plantas. Para saber mais clique no banner abaixo.

autolisps

Para receber minhas DICAS EXCLUSIVAS a Respeito de Legislação, Produtividade, Produção de plantas e Resolução de Problemas em Seu e-mail utilize o botão abaixo para acessar o formulário de inscrição.

CONHEÇA NOSSOS CURSOS

0 comentários:

Postar um comentário