hola ayuda con i rutina medir

Ver el tema anterior Ver el tema siguiente Ir abajo

hola ayuda con i rutina medir

Mensaje por mario198501 el Jue Nov 24, 2016 6:11 pm

hola amigos qu bueno lo del foro,... quisiera que me ayuden tego esta rutina medirr.lsp

lo que hace e medir ,picando el inico y final de una linea , lo hace siguidamente , el problema que tengo es que cuando cancelo,me aparece este mensaje autocad message...se calcelo el proceso... bueno que hago para que no me aparesca gracia por responder de antemano


......................................................................................................................



(defun c:medirr ()

;(setq ALT (GETREAL "Ingresa Altura de Texto: "))(TERPRI)
;(setq IND (GETINT "Ingresa Numero de Decimales: "))(TERPRI)
;(setq DD (GETREAL "Ingresa Altura de Texto: "))(TERPRI)


;preferible utilizarlo de derecha a izquierda

; (if (not ALT)
; (setq ALT 0.05)
; )
; (foreach msg (list "\nIngresa Altura de Texto : <" ALT "> ") (princ msg))
; (if (setq tmp (GETREAL))
; (setq ALT tmp )
; )

; (if (not IND)
; (setq IND 4)
; )
; (foreach msg (list "\Ingresa Numero de Decimales : <" IND "> ") (princ msg))
; (if (setq tmp (GETINT))
; (setq IND tmp)
; )

; (if (not DD)
; (setq DD 0.05)
; )
; (foreach msg (list "\nIngresa Distancia de Objeto a Texto : <" DD "> ") (princ msg))
; (if (setq tmp (GETREAL))
; (setq DD tmp )
; )







(setq REFNT0 (GETVAR "osmode"))
(setvar "osmode" 5)

(setq CN 1)

(While


(setq P1 (GETPOINT (STRCAT "\n-> Seleccione punto inicial " (ITOA CN) ":" )))(TERPRI)
(setq P2 (GETPOINT (STRCAT "\n-> Seleccione punto final " (ITOA CN) ":" )))(TERPRI)



(setq D1 (DISTANCE P1 P2))

(setq A1 (ANGLE P1 P2))
(setq A1D (* ( / A1 PI) 180 ))
(setq P3 (POLAR P1 A1 ( / D1 2)))
(setq P4 (POLAR P3 (+ (* PI 0.5) A1) 0.05))
(setq D1M (STRCAT (RTOS D1 2 10) "m"))

(setq CN (1+ CN))


;; (command "LINE" P1 P2 "")
(command "_.TEXT" "MC" P4 0.025 A1D D1M)


)

(setvar "osmode" REFNT0)


(princ)

)

mario198501

Mensajes : 12
Fecha de inscripción : 18/11/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por amc.dicsac el Miér Nov 30, 2016 6:37 pm

Hola que tal, revisando tu lisp encontre un problema adicional, cada vez que sales del bucle la variable "osmode" toma el valor que le indicas al inicio "5"
para eso añadi dentro del control de errores la opcion de que te restablesca la variable.

Código:

(defun c:medirr (/ *error* osm CN P1 P2 D1 A1 A1D P3 P4 D1M CN)
 
  (defun *error* ( msg )
        (if osm (setvar "osmode" osm))
        (if (not (member msg '("Function cancelled" "quit / exit abort")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

(setq osm (getvar "osmode"))
(setvar "osmode" 5)
(setvar "cmdecho" 0)
(setq CN 1)
(While
(setq P1 (GETPOINT (STRCAT "\n-> Seleccione punto inicial " (ITOA CN) ": " ))) (terpri)
(initget 32)
(setq P2 (GETPOINT P1 (STRCAT "\n-> Seleccione punto final " (ITOA CN) ": " ))) (terpri)
(setq D1 (DISTANCE P1 P2))
(setq A1 (ANGLE P1 P2))
(setq A1D (* ( / A1 PI) 180 ))
(setq P3 (POLAR P1 A1 ( / D1 2)))
(setq P4 (POLAR P3 (+ (* PI 0.5) A1) 0.05))
(setq D1M (STRCAT (RTOS D1 2 10) "m"))
(setq CN (1+ CN))
(command "_.TEXT" "MC" P4 0.025 A1D D1M))
(setvar "osmode" osm)
(setvar "cmdecho" 1)
(princ))
avatar
amc.dicsac

Mensajes : 78
Fecha de inscripción : 17/03/2016
Edad : 26
Localización : Lima - Perú

Ver perfil de usuario http://axprogramlisp.blogspot.pe/

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por Luis Alberto Benitez el Jue Dic 01, 2016 1:13 pm

amc.dicsac muy buena rutina estoy viendo la posibilidad de usarlo
para seleccionar un texto de una medida y que me sume seleccionando
un punto inicial y final y colocar el texto en un punto determinado si puedes aportar
al respecto muy agradecido.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 37
Fecha de inscripción : 29/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por mario198501 el Jue Dic 01, 2016 5:41 pm

gracias por responder ... necesitaba este control de errores me facilita el trabajo...gracias............... sobre la rutina de suma que pidieron comparto esta ...claro que no resuelve lo que pides....

;|***********************************************
rutina "stn" suma textos numericos,
funciona con TEXT y MTEXT no editados
(No formateados).
***********************************************
(c) by Prexem - Victor Adolfo Bracamonte - 2008
**** www.prexem.blogspot.com ****
***********************************************|;
(defun c:stn (/ sel p h cant index e data val n listn sum res)
(prompt
"\nSeleccione textos numericos a sumar, que no hayan sido editados:"
)
(setq sel (ssget '((0 . "MTEXT,TEXT")))
p (getpoint
"\nDar punto de inserción para texto final:"
)
h (getdist p "\nDar altura de texto:")
cant (sslength sel)
index 0
);setq
(repeat cant
(setq e (ssname sel index)
data (entget e)
val (cdr (assoc 1 data))
n (atof val)
listn (cons n listn)
index (1+ index)
);setq
);repeat
(setq sum (apply '+ listn))
(setq res (rtos sum 2 10))
(command "_.text" p h 0 res)
(princ)
);defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

mario198501

Mensajes : 12
Fecha de inscripción : 18/11/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por Luis Alberto Benitez el Jue Dic 01, 2016 8:05 pm

Mario gracias por el aporte es un buen intento para
continuar el armado del lisp.
Un saludo
Luis

Luis Alberto Benitez

Mensajes : 37
Fecha de inscripción : 29/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por amc.dicsac el Jue Dic 01, 2016 10:41 pm

Hola que tal, te adjunto la rutina que pediste ojala sea lo que nesecitas:

De preferencia los textos que vas a seleccionar asegurate que tengan el mismo tamaño, el mismo estilo y la misma capa.

Código:

(defun c:stn (/ *error* i ss e Entdata Cont hgt stl lay lst1 p1 p2 dst lst2 sum EntText)
   (defun *error* ( msg )
        (if (not (member msg '("Function cancelled" "quit / exit abort")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
(setvar "cmdecho" 0)
 (if
  (setq i -1 ss (LM:ssget "\nSelecciona Texto(s): " '("_:L" ((0 . "TEXT,MTEXT")))))
    (while
      (setq e (ssname ss (setq i (1+ i))))
      (setq Entdata (entget e))
      (setq Cont (atof (cdr (assoc 1 Entdata))))
      (setq hgt (cdr (assoc 40 Entdata)))
      (setq lay (cdr (assoc 8 Entdata)))
      (setq stl (cdr (assoc 7 Entdata)))
      (setq lst1 (cons Cont lst1))
     )
 )
(while
(setq p1 (getpoint "\n>> Especifica pto1: "))
(initget 32)
(setq p2 (getpoint p1 "\n>> Siguiente pto: "))
(setq dst (atof (rtos (distance p1 p2) 2 2)))
(setq lst2 (cons dst lst2))
(setq sum (strcat (rtos (apply '+ (append lst1 lst2)) 2 2) "m"))
(setq EntText (2ap_Draw_Text sum hgt stl lay))
(while (eq (car (setq pt (grread t 15 0))) 5)
(redraw)
(entmod (subst (cons 10 (cadr pt)) (assoc 10 (entget EntText)) (entget EntText)))))
(setvar "cmdecho" 1)
(princ))

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
    
(defun LM:ssget ( msg arg / sel )
  (princ msg)
  (setvar 'nomutt 1)
  (setq sel (vl-catch-all-apply 'ssget arg))
  (setvar 'nomutt 0)
  (if (not (vl-catch-all-error-p sel)) sel)
)

;;---------------------------------------------------;;
;; Creador de Texto ---> AX:ProgramLisp                  ;;
;; (2ap_Draw_Text "Hola" 0.1 "romans" "capa2") ;;
;;-------------------------------------------     ;;
(defun 2ap_Draw_Text (s h stl lay)
   (entmakex
      (list (cons 0   "TEXT")        
            (cons 100 "AcDbEntity")        
            (cons 100 "AcDbText")  
            (list 10 0. 0. 0.)
            (list 11 0. 0. 0.)
            (cons 71 0) ;; justify
            (cons 40 h) ;; height        
            (cons  1 s) ;; string
    (cons  7 stl)
    (cons  8 lay)
      )
   )
)
avatar
amc.dicsac

Mensajes : 78
Fecha de inscripción : 17/03/2016
Edad : 26
Localización : Lima - Perú

Ver perfil de usuario http://axprogramlisp.blogspot.pe/

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por Luis Alberto Benitez el Vie Dic 02, 2016 12:06 pm

amc.dicsac: Gracias por el aporte el lisp funciona muy bien.
Un saludo
Luis

Luis Alberto Benitez

Mensajes : 37
Fecha de inscripción : 29/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por Luis Alberto Benitez el Mar Dic 06, 2016 11:26 pm

amc.dicsac: Aquí elabore un lisp en base a la rutina que adjuntaste con algunas modificaciones para el caso de que tenga un solo texto y que del mismo partan las distintas mediciones y coloque el texto en los puntos que yo solicite lo que no estoy logrando lo mismo que el texto con Justificación II y el estilo que yo le solicite.Desde ya gracias por los aportes.
Un Saludo
Luis
Código:
(defun c:stnn (/ *error* i ss e Entdata Cont hgt stl lay lst1 p1 p2 dst lst2 sum EntText)
   (defun *error* ( msg )
        (if (not (member msg '("Function cancelled" "quit / exit abort")))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )
(setvar "cmdecho" 0)
(vl-cmdf "_UCS""u")
(setq osm (getvar "osmode"))
(command "orto""DES")
(setvar "CLAYER" "TEXTO")
(if
  (setq i -1 ss (LM:ssget "\nSeleccionar Texto: " '("_:L" ((0 . "TEXT,MTEXT")))))
    (while
      (setq e (ssname ss (setq i (1+ i))))
      
      (setq Entdata (entget e))
      (setq texto_obj_longitud (sslength ss))
      (setq p1 (cdr (assoc 11 Entdata)))  ;el punto de anclaje del Texto
      (setq Cont (atof (cdr (assoc 1 Entdata))))
      (setq hgt (cdr (assoc 40 Entdata)))
      ;(setq lay (cdr (assoc 8 Entdata)))
      (setq lay (setvar "CLAYER" "TEXTO"))

      (setq stl (cdr (assoc 7 Entdata)))
      
      (setq lst1 (cons Cont lst1))
      
     )
 )


(while
(setvar "osmode" 0)
(setvar "osmode" 32);interseccion
;(setq p1 (getpoint "\n>> Especificar pto1: "))
(initget 32)
(setvar "osmode" 0)
(setvar "osmode" 512);cercano
(setq p2 (getpoint p1 "\n>> Siguiente pto: "))
(setq dst (atof (rtos (distance p1 p2) 2 2)))

(setq lst2 (cons dst lst2))


(setq sum (strcat "Pr. " (rtos (APPLY '+ (append lst1 lst2)) 2 0)))
(setq EntText (2ap_Draw_Text sum hgt stl lay))
(while (eq (car (setq pt (grread t 15 0))) 5)
(redraw)
(entmod (subst (cons 10 (cadr pt)) (assoc 10 (entget EntText)) (entget EntText)))))
(setvar "cmdecho" 1)
(princ))

;; ssget  -  Lee Mac
;; Un contenedor para la función ssget para permitir el uso de una solicitud de selección personalizada
;; msg - [str] mensaje de selección
;; arg - [lst] Lista de argumentos ssget
    
(defun LM:ssget ( msg arg / sel )
  (princ msg)
  (setvar 'nomutt 1);Suprime la visualización de mensajes (silenciamiento) que no se suprimiría normalmente
                  ;0 Reanuda el comportamiento normal de silenciamiento.
                  ;1 Suprime el silenciamiento de forma indefinida.

  (setq sel (vl-catch-all-apply 'ssget arg))
  (setvar 'nomutt 0);Suprime la visualización de mensajes (silenciamiento) que no se suprimiría normalmente
                  ;0 Reanuda el comportamiento normal de silenciamiento.
                  ;1 Suprime el silenciamiento de forma indefinida.

  (if (not (vl-catch-all-error-p sel)) sel)
)

;; ssget  -  Lee Mac
;; Un contenedor para la función ssget para permitir el uso de una solicitud de selección personalizada
;; msg - [str] mensaje de selección
;; arg - [lst] lLista de argumentos ssget
    
(defun LM:ssget ( msg arg / sel )
  (princ msg)
  (setvar 'nomutt 1)
  (setq sel (vl-catch-all-apply 'ssget arg))
  (setvar 'nomutt 0)
  (if (not (vl-catch-all-error-p sel)) sel)
)

;;---------------------------------------------------;;
;; Creador de Texto ---> AX:ProgramLisp              ;;
;; (2ap_Draw_Text "Hola" 0.1 "romans" "capa2")       ;;
;;---------------------------------------------------;;
(defun LM:ssget ( msg arg / sel )
  (princ msg)
  (setvar 'nomutt 1);Suprime la visualización de mensajes (silenciamiento) que no se suprimiría normalmente
                  ;0 Reanuda el comportamiento normal de silenciamiento.
                  ;1 Suprime el silenciamiento de forma indefinida.

  (setq sel (vl-catch-all-apply 'ssget arg))
  (setvar 'nomutt 0);Suprime la visualización de mensajes (silenciamiento) que no se suprimiría normalmente
                  ;0 Reanuda el comportamiento normal de silenciamiento.
                  ;1 Suprime el silenciamiento de forma indefinida.

  (if (not (vl-catch-all-error-p sel)) sel)
)

;;---------------------------------------------------;;
;; Creador de Texto ---> AX:ProgramLisp              ;;
;; (2ap_Draw_Text "Hola" 0.1 "romans" "capa2")       ;;
;;---------------------------------------------------;;


(defun 2ap_Draw_Text (s h stl lay)
   (entmakex
      (list (cons 0   "TEXT")        
            (cons 100 "AcDbEntity")        
            (cons 100 "AcDbText")  
            (list 10 0. 0. 0.)
            (list 11 0. 0. 0.)
            (cons 71 0)    ;; Justificar
            (cons 40 7.5)  ;; altura de texto
            (cons  1 s)    ;; cuerda
            (cons 50 1.570797) ;; Rotación del Texto, para convertir sexagesimal a radianes 1 x 0.0174533

    (cons  7 stl)
    (cons  8 lay)
      )
   )
)

Luis Alberto Benitez

Mensajes : 37
Fecha de inscripción : 29/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por amc.dicsac el Miér Dic 07, 2016 7:19 pm

Hola que tal, cambie algunas cosas que ya están indicadas, prueba y luego me cuentas que tal te fue.

Código:
(defun c:stn (/ *error* var val i ss e Entdata Cont hgt stl lay lst1 p1 p2 dst lst2 sum ins)
   (defun *error* ( msg )
        (mapcar 'setvar var val) ;; restablecemos las variables cuando tecleamos "esc"
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )  
(setq var '(cmdecho osmode orthomode clayer)
      val (mapcar 'getvar var)
 )
(2ap_Draw_Layer "TEXTO" 7 "Continuous" 1) ;; en caso de que la capa "TEXTO" no exista en la creamos
 (if
  (setq i -1 ss (LM:ssget "\nSeleccionar Texto: " '("_:L" ((0 . "TEXT,MTEXT")))))
    (while
      (setq e (ssname ss (setq i (1+ i))))
      (setq Entdata (entget e))
      (setq texto_obj_longitud (sslength ss))
      ;; (setq p1 (cdr (assoc 11 Entdata)))  ;; este codigo no lo necesitamos
      (setq Cont (atof (cdr (assoc 1 Entdata))))
      (setq hgt (cdr (assoc 40 Entdata)))
      (setq stl (cdr (assoc 7 Entdata)))
      (setq lst1 (cons Cont lst1))      
     )
 )
(while
(mapcar 'setvar var '(0 544 0 "TEXTOS")) ;; aqui modificamos las variables segun nuestra necesidad
(setq p1 (getpoint "\n>> Especificar pto1: "))
(initget 32)
(setq p2 (getpoint p1 "\n>> Siguiente pto: "))
(setq dst (atof (rtos (distance p1 p2) 2 2)))
(setq lst2 (cons dst lst2))
(setq sum (strcat "Pr. " (rtos (APPLY '+ (append lst1 lst2)) 2 0)))
(setq ins (getpoint (strcat "\n>> Especifique insercion de texto [ " sum "]: ")))

(vl-cmdf "_.text" "_s" stl "J" "tl" ins hgt 1.570797 sum));; aqui reemplaza "TL --> TOP LEFT" por la justificacion que quieras
                                                   ;; [Align/Fit/Center/Middle/Right/TL/TC/TR/ML/MC/MR/BL/BC/BR]        
(mapcar 'setvar var val) ;; aqui restablecemos las variables
(princ))

;; ssget  -  Lee Mac                                                                                        
;; Un contenedor para la función ssget para permitir el uso de una solicitud de selección personalizada    
;; msg - [str] mensaje de selección                                                                        
;; arg - [lst] Lista de argumentos ssget                                                                    
;;----------------------------------------------------------------------------------------------------------
;; La variable nommut Suprime la visualización de mensajes (silenciamiento) que no se suprimiría normalmente
;; 0 Reanuda el comportamiento normal de silenciamiento.                                                    
;; 1 Suprime el silenciamiento de forma indefinida.                                                        

(defun LM:ssget ( msg arg / sel )
  (princ msg)
  (setvar 'nomutt 1)
  (setq sel (vl-catch-all-apply 'ssget arg))
  (setvar 'nomutt 0)
  (if (not (vl-catch-all-error-p sel)) sel)
)

;;---------------------------------------------;;
;; Creador de layer ---> AX:ProgramLisp        ;;
;; (2ap_Draw_Layer "layer_1" 2 "Continuous" 1) ;;
;;---------------------------------------------;;
(defun 2ap_Draw_Layer ( name color ltype plt)
(if (null (tblobjname "LAYER" name))
(entmake (list '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
                (cons 2 name)   ;; nombre de capa
       '(70 . 0)
        (cons 62 color) ;; el color de capa
                (cons 6 ltype)  ;; tipo de linea de capa
        (cons 290 plt)  ;; si pones 0 la capa no se imprimira si pones 1 la capa si se imprimira
                ;; (cons 370 lwt)  ;; el grosor de la capa (es opcional)
      )
    )
  )
)
avatar
amc.dicsac

Mensajes : 78
Fecha de inscripción : 17/03/2016
Edad : 26
Localización : Lima - Perú

Ver perfil de usuario http://axprogramlisp.blogspot.pe/

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por Luis Alberto Benitez el Miér Dic 07, 2016 8:04 pm

amc.dissac: Gracias por la respuesta pero no es precisamente lo que quiero
el lisp que modifique tiende mas a lo que pretendo pero lo que hace es sumar
el acumulado de la distancia y no sumar a partir del mismo texto y lo otro que pretendo es que al insertar el texto me cambie el estilo de texto.
Si me envías tu correo te explico mejor.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 37
Fecha de inscripción : 29/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por amc.dicsac el Miér Dic 07, 2016 8:47 pm

Ok Luis no hay ningun problema te envio mi correo amc.dicsac@gmail.com
avatar
amc.dicsac

Mensajes : 78
Fecha de inscripción : 17/03/2016
Edad : 26
Localización : Lima - Perú

Ver perfil de usuario http://axprogramlisp.blogspot.pe/

Volver arriba Ir abajo

Re: hola ayuda con i rutina medir

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba

- Temas similares

 
Permisos de este foro:
No puedes responder a temas en este foro.