acad hispano
¿Quieres reaccionar a este mensaje? Regístrate en el foro con unos pocos clics o inicia sesión para continuar.

Ayuda con este lisp

4 participantes

Ir abajo

Ayuda con este lisp Empty Ayuda con este lisp

Mensaje por Francisco Manjarrez Mar Oct 17, 2017 9:43 am

Hola muy buen día, les solicito de la manera mas atenta ayuda con este lips que hasta hace poco funcionaba muy bien, no es de mi autoría pero lo conseguí en Hispacad y resulta de mucha utilidad, pues enlaza el área de un objeto con un texto con un par de clicks, y si se modifica el polígono enlazado se actualiza el texto enlazado, solo que ahora en la versión acad 17 al momento de modificar el polígono se queda ciclado el lisp o reactor, sin poder desbloquear la maquina con nada. el comando dentro de lisp es "aat" para enlazar el poligono y el texto
Les agradeceria su ayuda.

PD espero haberme explicado...

Código:
;;  Lisp per associar arees amb textes i textes entre ells. per d.tordera, 2000 (dtordera@hotmail.com)
;;  S'utilitzen reactors persistents y les propietats dels objectes directament.          
;;                                          
;;

(defun nstr(param)
  (if (= param nil) quit)
  (setq res "")
  (setq i 0)
  (setq ln (strlen param))
  (while (< i ln)
    (setq i (+ i 1))
    (setq C (substr param i 1))
    (if (and (>= (ascii C) (ascii ","))
       (<= (ascii C) (ascii "9"))
   )
      (setq res (strcat res C)))   
    )
  (atof res)
)

(defun c:suma()
  (vl-load-com)
 
  (princ "\n\t Selecciona obj. :")
  (setq slct (ssget))
  (setq cnt (sslength slct))
  (princ cnt)
  (setq sum 0.0)
  (while (> cnt 0)
    (setq cnt (- cnt 1))
    (setq SRC (vlax-ename->vla-object (ssname slct cnt)))
    (if  ( = (vlax-property-available-p  SRC 'TextString) T)
      (progn
   (setq txt (vlax-get-property SRC 'TextString))
   (setq ato (nstr txt))
   (setq sum (+ sum ato))
   (princ "\n + ")
         (princ ato)
   (princ "\t = ")
   (princ sum)
      ) 
    )
  )
  (princ "\ntotal suma: ")
  (princ sum)
  (princ)
)

(defun c:sumat()
  (vl-load-com)
 
  (princ "\n\t Selecciona obj. :")
 
  (setq slct (ssget))
  (setq cnt (sslength slct))
  (princ cnt)
  (setq sum 0.0)
  (while (> cnt 0)
    (setq cnt (- cnt 1))
    (setq SRC (vlax-ename->vla-object (ssname slct cnt)))
    (if  ( = (vlax-property-available-p  SRC 'TextString) T)
      (progn
   (setq txt (vlax-get-property SRC 'TextString))
   (setq ato (atof txt))
   (setq sum (+ sum ato))
   (princ "\n + ")
         (princ ato)
   (princ "\t = ")
   (princ sum)
      ) 
    )
  )
  (princ "\ntotal suma: ")
  (princ sum)
; posem el nou texte al objecte copia

  (setq CPY (vlax-ename->vla-object (car (entsel "\n\tSeleccionar objecte destí :"))))
    ; es comproba que te texte
      (if  ( = (vlax-property-available-p  CPY 'TextString) F)
   (progn
     (princ "\nL'objecte escollit no conté texte")
     (princ "\n")
     (quit)
   )
      )
 
  (vlax-put-property CPY 'TextString (rtos sum 2)) 
  (princ)
)
 
(defun c:athelp()

  (princ "\n athelp : muestra ayuda")
  (princ "\n eta    : elimina todas las reacciones del dibujo")
  (princ "\n ea    : elimina todas las asociaciones del objeto")
  (princ "\n at    : asocia dos objetos de texto")
  (princ "\n aat    : asocia objetos de texto a un area")
  (princ "\n suma  : suma valores de texto")
  (princ "\n sumat  : suma valores de textos en un tercer texto")
  (princ)
)

;; AT - Associa Texte : quan es modifica l'origen SRC canvia la copia CPY

(defun c:at()
      (vl-load-com)
  ;;
  ;  Seleccionem la font (SRC)
  ;;
      (setq SRC (vlax-ename->vla-object (car (entsel "\n\tSeleccionar objecte font :"))))
    ; es comproba que te texte
      (if  ( = (vlax-property-available-p  SRC 'TextString) F)
   (progn
     (princ "\nL'objecte escollit no conté texte")
     (princ "\n")
     (quit)
   )
      )
      (setq txt (vlax-get-property SRC 'TextString))
      (princ txt)
  ;;
  ;  Seleccionem el destí (CPY)
  ;;
      (setq CPY (vlax-ename->vla-object (car (entsel "\n\tSeleccionar objecte destí :"))))
    ; es comproba que te texte
      (if  ( = (vlax-property-available-p  CPY 'TextString) F)
   (progn
     (princ "\nL'objecte escollit no conté texte")
     (princ "\n")
     (quit)
   )
      )

    ; posem el nou texte al objecte copia

      (vlax-put-property CPY 'TextString (vlax-get-property SRC 'TextString))
 
  ;;
  ;Creem reactor de modificació sobre SRC (amb informació de CPY)
  ;Creem reactor de eliminació sobre SRC
  ;;
      (setq modifyReactor (vlr-object-reactor (list SRC)
             CPY '((:vlr-modified . igualar_texte)
              (:vlr-erased  . sense_referencia)))) 

  ;;
  ; creem reactor d'eliminació sobre la copia : en el cas que es borri, elimina el reactor
  ; de SRC de modificació
  ;;
      (setq src_eliminacio (vlr-object-reactor(list CPY)
               SRC '((:vlr-erased . eliminar_copia))))

  (vlr-pers modifyReactor)
  (vlr-pers src_eliminacio)

  (princ "\n eta : elimina todas las recciones del dibujo")
  (princ "\n ea : elimina todas las asociaciones de un objeto")
  (princ "\n va : marca objetos asociados")
  (princ "\n aat : asocia objetos de texto a un area")
  (princ "\nAssociació creada.")
  (princ)
 )

(defun c:eta()
      (vl-load-com)
       
      (foreach reactor (vlr-pers-list)
    (progn
          (vlr-pers-release reactor)
     (vlr-remove reactor)
        )
      )
     
      (princ "\nReaccions / associacions eliminades")
      (princ)
)

(defun c:va()
      (vl-load-com)
  ;;
  ;  Seleccionem la font (SRC)
  ;;
      (setq SRC (vlax-ename->vla-object (car (entsel "\n\tSeleccionar font d'associació"))))

     
)

(defun c:aat()
      (vl-load-com)
  ;;
  ;  Seleccionem la font (SRC)
  ;;
      (setq SRC (vlax-ename->vla-object (car (entsel "\n\tSeleccionar objecte font (polilinea o cercle,etc...):"))))
    ; es comproba que tingui area
      (if  ( = (vlax-property-available-p  SRC 'Area) F)
   (progn
     (princ "\nL'objecte escollit no conté area")
     (princ "\n")
     (quit)
   )
      )
      (princ (vlax-get-property SRC 'Area))
     
  ;;
  ;  Seleccionem el destí (CPY)
  ;;
      (setq CPY (vlax-ename->vla-object (car (entsel "\n\tSeleccionar objecte destí :"))))
    ; es comproba que te texte
      (if  ( = (vlax-property-available-p  CPY 'TextString) F)
   (progn
     (princ "\nL'objecte escollit no conté texte")
     (princ "\n")
     (quit)
   )
      )

    ; posem el nou texte al objecte copia
     (setq txt (strcat (rtos (vlax-get-property SRC 'Area) 2 2) ))
        (vlax-put-property CPY 'TextString txt)
 
  ;;
  ;Creem reactor de modificació sobre SRC (amb informació de CPY)
  ;Creem reactor de eliminació sobre SRC
  ;;
      (setq modifyReactor
         (vlr-object-reactor (list SRC) CPY '((:vlr-modified . igualar_area)
                    (:vlr-erased  . sense_referencia)))
      )

      (setq src_eliminacio
         (vlr-object-reactor (list CPY) SRC '((:vlr-erased . eliminar_copia)))
      )

  (vlr-pers modifyReactor)
  (vlr-pers src_eliminacio)

  (princ "\n ea : elimina todas las asociaciones de un objeto")
  (princ "\n va : crea lineas entre objetos asociados")
  (princ "\n at : asocia objeto de texto entre un tercer objeto de texto")
  (princ "\nAssociació creada.")
  (princ)
)

(defun c:ea ()
  (setq SRC (vlax-ename->vla-object (car (entsel "\n\tSeleccionar font d'associació :"))))

  (Eliminar_reactors_de SRC)
)

;;;;; FUNCIONS    ;;;;;;;

(defun Eliminar_reactors_de (objecte)
 
  (vl-load-com)
  (setq lst (vlr-pers-list))
 
  (foreach reactor lst
    (progn
       (setq objecte_desti (vlr-data reactor))
     
        (if (or
         (= (vlax-erased-p objecte_desti) T)
         (= (vla-get-handle objecte) (vla-get-handle objecte_desti))
       )
     (progn
           (princ "\n")
       (princ reactor)
       (princ "\tEliminat")
       (vlr-pers-release reactor)
           (vlr-remove reactor)
      
         )
   )
    )
  )

  (setq lst (vlr-pers-list))
 
  (foreach reactor lst
    (progn
      (setq owner (vlr-owners reactor))

      (if (or
       (= (vlax-erased-p owner) T)
       (= (vla-get-handle owner) (vla-get-handle objecte))
     )
    (progn
     (princ "\n")
     (princ reactor)
     (princ "\tEliminat")
     (vlr-pers-release reactor)
     (vlr-remove reactor)
    
    )
      )
    )
  )
 
  (princ "\nReactors d'objecte eliminat")
)

;;;;; REACCIONS    ;;;;;;,

(defun eliminar_copia (notifier-object reactor-object parameter-list)
  (vl-load-com)
  (Eliminar_reactors_de (vlr-data reactor-object))
  (Eliminar_reactors_de notifier-object)
  (princ "\nAquest element estaba associat . Associació trencada")
  (princ)
)

(defun igualar_area (notifier-object reactor-object parameter-list)
  (vl-load-com)

  (setq CPY (vlr-data reactor-object))
  (setq txt (rtos (vlax-get-property notifier-object 'Area) 2 2))
 
  (vlax-put-property CPY 'TextString txt )
  (princ "\nReferencia actualitzada : ")
  (princ (vlax-get-property CPY 'TextString))
  (princ)
)     


(defun sense_referencia (notifier-object reactor-object parameter-list)
  (vl-load-com)
  (setq CPY (vlr-data reactor-object))

  (Eliminar_reactors_de notifier_object)
  (Eliminar_reactors_de CPY)
 
  (vlax-put-property CPY 'TextString "#sense_ref!#")
  (princ "\nL'objecte eliminat era font d'associació. Associació trencada.")
  (princ)
)
 
(defun igualar_texte (notifier-object reactor-object parameter-list)
  (vl-load-com)
  (setq CPY (vlr-data reactor-object))
  (vlax-put-property CPY 'TextString (vlax-get-property notifier-object 'TextString))
  (princ "\nReferencia actualitzada : ")
  (princ (vlax-get-property CPY 'TextString))
  (princ)
)

Francisco Manjarrez

Mensajes : 14
Fecha de inscripción : 10/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Francisco Manjarrez Mar Oct 17, 2017 7:34 pm

Sorry les dejo un dibujo demostrativo para que se entienda mejor el caso, ahi ya esta aplicado el lisp y solo hay que modificar el poligono para que de el error, trabajo en acad17...

De antemano gracias

https://www.dropbox.com/s/zsx1lrzpcg2144k/DIBUJO%20PRUEBA.dwg?dl=0

Francisco Manjarrez

Mensajes : 14
Fecha de inscripción : 10/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por nolo Dom Oct 22, 2017 9:11 pm

Lo de los reactor es un poco complejo, pero creo que lo que hace se puede hacer con mtext directamente asociando un campo al texto
¿Lo has probado?
Dibujo->texto en líneas multiples y en el editor, la pestañita derecha arriba y sobre insertar campo->objeto->Área
Con un regen se actualizan todos


Un saludo

nolo

Mensajes : 182
Fecha de inscripción : 17/03/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Francisco Manjarrez Vie Oct 27, 2017 6:06 pm

Hola!! buen día a todos!!
Si Nolo de hecho tengo uno que hace eso, pero en realidad este lo hace en tiempo real, y mi inquietud era mas bien por aprender algo, pues mi conocimiento es muy limitado.

De antemano muchas gracias por tomarte el tiempo Nolo.

Francisco Manjarrez

Mensajes : 14
Fecha de inscripción : 10/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por devitg Sáb Oct 28, 2017 9:23 pm

El tema VECTOR, es ,digamos, VL-LISP SUPERIOR . He visto muy pocas aplicaciones , y hay que estar muy ducho en VL-LISP , para entenderlo.
Yo lo compararía como tocar la 9ª sinfonía de Bethoven y cantar el Cumpleaños feliz.

devitg
Admin

Mensajes : 257
Fecha de inscripción : 16/03/2016
Edad : 75
Localización : CORDOBA ARGENTINA

https://acadhispano.foroargentina.net

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Francisco Manjarrez Lun Oct 30, 2017 8:05 pm

Jajajajaja ok entiendo... y la verdad son muy pocos conocimientos en lo que a Lisp se refiere.

Gracias por sus comentarios Saludos!!!

Francisco Manjarrez

Mensajes : 14
Fecha de inscripción : 10/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Marco Jacinto Mar Oct 31, 2017 10:15 pm

Francisco, el problema estaba en estas dos funciones
Código:

(DEFUN igualar_area (notifier-object reactor-object parameter-list)
  
  ;;;Se agrego esta bandera (flag) para saber si se estaba modificando el objeto
  ;;;ya que el reactor se metia en un buque infinito.
  (IF (NOT bandera)
    (PROGN
      (SETQ CPY (VLR-DATA reactor-object))
      (SETQ txt (RTOS (VLAX-GET-PROPERTY notifier-object 'Area) 2 2))
      (VLAX-PUT-PROPERTY CPY 'TextString txt)
      (PRINC "\nReferencia actualizada : ")
      (PRINC (VLAX-GET-PROPERTY CPY 'TextString))
      (setq bandera t)
    )
    (setq bandera nil)
  )
  (PRINC)
)

(DEFUN igualar_texte (notifier-object reactor-object parameter-list)
  
  (IF (NOT bandera)
    (PROGN
      (SETQ CPY (VLR-DATA reactor-object))
      (VLAX-PUT-PROPERTY
 CPY
 'TextString
 (VLAX-GET-PROPERTY notifier-object 'TextString)
      )
      (PRINC "\nReferencia actualizada : ")
      (PRINC (VLAX-GET-PROPERTY CPY 'TextString))
    )
    (SETQ bandera nil)
  )
  (PRINC)
)
las cuales se disparan al modificar el texto o el objeto del que se lee el área, de los cuales autocad no los libera y muestra indefinidamente el letrero de "Referencia actualizada : AREA"

Para evitarlo, puse una bandera para que solo la primera vez actualice el texto y la siguiente vez borre la bandera.

Marco Jacinto

Mensajes : 91
Fecha de inscripción : 12/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Francisco Manjarrez Mar Oct 31, 2017 11:52 pm

Marco Jacinto: Muchas gracias!!! funciona de maravilla!!!

Francisco Manjarrez

Mensajes : 14
Fecha de inscripción : 10/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Marco Jacinto Miér Nov 01, 2017 12:36 am

Un placer, aunque si de aprender se trata, buscaría por el camino de los campos que te mencionaban Nolo y Gabriel, algo mas o menos asi...

Código:
;;;Comando AreaACampo, creado por Marco Jacinto. Octubre 2017 para http://acadhispano.foroargentina.net
;;;Link Original http://acadhispano.foroargentina.net/t155-ayuda-con-este-lisp#1170

(DEFUN c:Area2Field (/ EntArea objtxt EspacioActual ObjArea)
;;;Se establece la variable ErrNo (numero de error) en 0, para que la rutina
;;;pueda salir en caso que al seleccionar un objeto se presione ENTER
  (SETVAR "errno" 0)
;;;Se obtiene el espacio de trabajo actual, importante cuando se
;;;esta trabajando en algun viewport dentro de layout
  (SETQ EspacioActual
 (VLAX-GET
   (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))
   (IF (EQUAL (GETVAR "cvport") 1)
     "PaperSpace"
     "ModelSpace"
   )
 )
  )
  (WHILE (NOT ObjArea)
    (SETQ EntArea (ENTSEL "\n Selecciona un objeto que tenga area: "))
    (COND
      ;;;Si en lugar de seleccionar un objeto se presiona ENTER, la rutina termina
      ((= (GETVAR "errno") 52) (SETQ ObjArea T))
      ;;;Si se selecciona un objeto con la propiedad Area, se pide un punto para
      ;;;crear el texto con el campo
      ((AND EntArea
    (VLAX-PROPERTY-AVAILABLE-P
      (SETQ ObjArea (VLAX-ENAME->VLA-OBJECT (CAR EntArea)))
      'Area
    )
       )
       (VLA-ADDTEXT
 EspacioActual
 (STRCAT "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
 (ITOA (VLA-GET-OBJECTID ObjArea))
 ">%).Area \\f \"%lu2%pr3%th44\">%"
 )
 (VLAX-3D-POINT
   (GETPOINT "\n Selecciona punto para insertar el área del objeto seleccionado...")
 )
 (* (GETVAR 'dimscale) 1.50)
       )
      )
      ;;;Si se selecciona un objeto que no tiene área, se pedira intentarlo de nuevo.
      (T (princ "\n El objeto no tiene área, intenta de nuevo...")
       (SETQ ObjArea nil))
    )
  )
  (PRINC)
)

Le puse algunos ejemplos de código que en su momento me hicieron sudar, pero que me dejaron grandes satisfacciones. Cualquier duda por aqui ando.

Marco Jacinto

Mensajes : 91
Fecha de inscripción : 12/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Francisco Manjarrez Jue Nov 23, 2017 2:03 am

Hola buen día!!! perdón pero he andado un poco ocupado y no había podido conectarme...
Los dos muy buenos funcionan muy bien muchas gracias!!!!

Francisco Manjarrez

Mensajes : 14
Fecha de inscripción : 10/08/2016

Volver arriba Ir abajo

Ayuda con este lisp Empty Re: Ayuda con este lisp

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Volver arriba

- Temas similares

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