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

Texto a Bloque Atributo

3 participantes

Ir abajo

Texto a Bloque Atributo Empty Texto a Bloque Atributo

Mensaje por SushyM Miér Sep 13, 2017 4:06 pm

Buenos dias, estuve buscando y parece que aca me podrian ayudar, no domino mucho el tema de como hacer una rutina por eso espero me puedan ayudar con alguna rutina que pueda hacer esto.

Tengo unos textos y multitextos, y necesito pasarlo a bloque, como el modelo que os envio.

He visto que no se puede adjuntar , por eso lo envio por la nube, https:// drive.google.com/file/d/0B3HBbf2wcY4nR0FGZWVPZ2hEc0k/view?usp=sharing  ojala chicos pueda contar con su ayudita....

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por saulo2016 Miér Sep 13, 2017 6:21 pm

Hola  SushyM, espero que esto te sirva, es un codigo muy viejito, ojalá y funcione bien.

Código:
;Tip1791:  TXT2ATTDEF.LSP  TEXT TO ATTRIBUTES              (c)2002, Sanjay Kulkarni

(defun
   C:TXT2ATTDEF ()
  (setq PCMDECHO (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq TXT1 (entget (car (entsel "\nSelect Text : "))))
  (setq IFTXT (cdr (assoc 0 TXT1)))
  (while (/= IFTXT "TEXT")
    (setq
      TXT1
       (entget
         (car
           (entsel
             (strcat
               "\nSelection Error !! You selected "
               IFTXT
               "! \nPlease Select Text : "
             ) ;_ end of strcat
           ) ;_ end of entsel
         ) ;_ end of car
       ) ;_ end of entget
    ) ;_ end of setq
    (setq IFTXT (cdr (assoc 0 TXT1)))
  ) ;_ end of while
  (setq TXT1VAL (cdr (assoc 1 TXT1)))
  (setq TXT1IP (cdr (assoc 10 TXT1)))
  (setq TXT1HT (cdr (assoc 40 TXT1)))
  (setq TXT1ROT (cdr (assoc 50 TXT1)))
  (setq APRMPT (getstring T "\nAttribute prompt : "))
  (entdel (cdar TXT1))
  (setq PAFLAGS (getvar "AFLAGS"))
  (setvar "AFLAGS" 0)
  (command
    "attdef"
    ""
    TXT1VAL
    APRMPT
    TXT1VAL
    TXT1IP
    TXT1HT
    (/ (* TXT1ROT 180) (/ 22.0 7.0))
  ) ;_ end of command
  (setvar "AFLAGS" PAFLAGS)
  ;;(alert "\n\t(c) 2000 SanganakSakha \n\tSanganakSakha@ivillage.com")
  (setvar "CMDECHO" PCMDECHO)
  (princ)
) ;defun txt2attdef
(alert
  "\t\t* AutoCAD 14 & AutoCAD 2000/2000i/2002 *\n\n\nThis routine converts the selected string to an attribute definition. \n\nTag and Default value of the new attribute are the same as the string being converted. \n\nThe new Attribute definition by default will be with ICVP value 'NNNN'. \n\nYou can change any/all attributes of this attdef subsequently using 'ddmodify' command. \n\n\nType 'txt2attdef' to execute.\n\n"
) ;_ end of alert
;;End Of Routine

Saludos
saulo2016
saulo2016

Mensajes : 210
Fecha de inscripción : 17/03/2016
Edad : 58
Localización : Monterrey, Nuevo León, Mexico

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Miér Sep 13, 2017 6:42 pm

Hola, gracias por tu apoyo, parece que hay problema ya que como tengo la version 2018 del autocad y me da un mensaje y no se si se ejecute bien.

Mi idea es tener dos tipos de bloques, uno para texto simple y otro para multitexto,
Text: El bloque 01 debe ser el mismo solo donde cambiaria es el contenido del atributo
Mtext: El bloque 02 debe ser el mismo solo donde cambiaria es el contenido del atributo.

Gracias.

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Vie Sep 15, 2017 9:17 pm

Hello , que tal
He buscado por la web, pero no he tenido suerte en encotrar algo que me ayude a convertirlos, ojala si pueden este fin de semana me dan esa gran ayuda que necesito chicos.


SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por nolo Sáb Sep 16, 2017 1:29 am

Mi máquina con acad14 32 dice que el archivo esta corrupto y cuando lo recupero me salen solo dos círculos que no contienen texto alguno
Igual le pasa a los demás lo mismo.....

Un saludo

nolo

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

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Sáb Sep 16, 2017 6:31 pm

Lo he grabado con otra version mas anterior
https:// drive.google.com/open?id=0B3HBbf2wcY4nb1VfQkpZYjBZeVE
Ahora si deberia abrir.
:-)

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Sáb Sep 16, 2017 7:12 pm

Encontre una rutina, lo convierte el texto en bloque pero el resultado, el bloque lo rota y lo deja horizontal.
Código:

; Convierte texto en atributo de bloque.
 ; Program by Tony Hotchkiss
(defun dxf (code ename) (cdr (assoc code (entget ename))))
(defun make-attributes (ss blockname / i tmsg pmsg t-str p-str en ins-pt txt-ht txt-str txt-style lyr btble)
  (setq i    (- 1)
        tmsg  "\nSolicitud: "
        pmsg  (strcat "\nAtributo sin nombrte" " devuelve el mismo que el identificador: ")
        t-str (getstring tmsg)
        p-str (getstring t pmsg)
  )
  (repeat (sslength ss)
      (setq en        (ssname ss (setq i (1+ i)))
            ins-pt    (dxf 10 en)
            txt-ht    (dxf 40 en)
            txt-str  (dxf 1 en)
            txt-style (dxf 7 en)
            lyr      (dxf 8 en)
      )
      (setq btble (tblsearch "BLOCK" blockname))
      (if (= btble nil)
        (progn (entmake (list '(0 . "BLOCK")
                              '(100 . "AcDbEntity")
                              (cons 8 lyr)
                              '(100 . "AcDbBlockBegin")
                              (cons 2 blockname)
                              '(70 . 2)
                              (cons 10 ins-pt)
                        )
                )
                (entmake (list '(0 . "ATTDEF")
                              '(100 . "AcDbEntity")
                              '(67 . 0)
                              (cons 8 lyr)
                              '(100 . "AcDbText")
                              (cons 10 ins-pt)
                              (cons 40 txt-ht)
                              '(1 . "")
                              (cons 7 txt-style)
                              '(100 . "AcDbAttributeDefinition")
                              (cons 3 p-str)
                              (cons 2 (strcase t-str))
                              '(70 . 0)
                        )
                )
                (setq bname (entmake (list '(0 . "ENDBLK") '(100 . "AcDbEntity") (cons 8 lyr) '(100 . "AcDbBlockEnd"))))
        )
      )
      (entmake (list '(0 . "INSERT")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbBlockReference")
                    '(66 . 1)
                    (cons 2 bname)
                    (cons 10 ins-pt)
              )
      )
      (entmake (list '(0 . "ATTRIB")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbText")
                    (cons 10 ins-pt)
                    (cons 40 txt-ht)
                    (cons 1 txt-str)
                    (cons 7 txt-style)
                    '(100 . "AcDbAttribute")
                    (cons 2 t-str)
                    '(70 . 0)
              )
      )
      (entmake '((0 . "SEQEND")))
      (entdel en)
  )
  (princ)
)
(defun c:txt_att (/ block-exists blockname btble ss)
  (setq block-exists t)
  (while block-exists
      (setq blockname (getstring "Nombre de bloque: "))
      (setq btble (tblsearch "BLOCK" blockname))
      (if btble
        (progn (setq block-exists t) (prompt "\nNombre de bloque existente, Enter "))
        (progn (setq block-exists nil))
      )
  )
  (setq ss nil)
  (prompt "\nSeleccionar texto: ")
  (while (= ss nil)
      (setq ss (ssget '((0 . "TEXT"))))
      (if (= ss nil)
        (prompt "\nNingun texto seleccionado, Seleccionar texto: ")
      )
  )
  (if ss
      (progn (make-attributes ss blockname))
  )
)

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Sáb Sep 16, 2017 7:14 pm

Se deberia dejar el bloque igual al angulo de rotacion del Texto, pero no sirve para Mtext
:-)

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por nolo Dom Sep 17, 2017 6:53 pm

Bueno Sushy, ahora si lo he podido cargar ...
Al código que subiste de Tony Hotchkiss solo le falta recuperar el código 50 del texto y ponérselo al atributo en la subfunción principal
Aquí te la dejo corregida para que no tengas que pensar
Código:
(defun make-attributes (ss blockname / rot i tmsg pmsg t-str p-str en ins-pt txt-ht txt-str txt-style lyr btble)
  (setq i    (- 1)
        tmsg  "\nSolicitud: "
        pmsg  (strcat "\nAtributo sin nombrte" " devuelve el mismo que el identificador: ")
        t-str (getstring tmsg)
        p-str (getstring t pmsg)
  )
  (repeat (sslength ss)
      (setq en        (ssname ss (setq i (1+ i)))
            ins-pt    (dxf 10 en)
            txt-ht    (dxf 40 en)
            txt-str  (dxf 1 en)
            txt-style (dxf 7 en)
            lyr      (dxf 8 en)
            rot (dxf 50 en);;; <----

      )
      (setq btble (tblsearch "BLOCK" blockname))
      (if (= btble nil)
        (progn (entmake (list '(0 . "BLOCK")
                              '(100 . "AcDbEntity")
                              (cons 8 lyr)
                              '(100 . "AcDbBlockBegin")
                              (cons 2 blockname)
                              '(70 . 2)
                              (cons 10 ins-pt)
                        )
                )
                (entmake (list '(0 . "ATTDEF")
                              '(100 . "AcDbEntity")
                              '(67 . 0)
                              (cons 8 lyr)
                              '(100 . "AcDbText")
                              (cons 10 ins-pt)
                              (cons 40 txt-ht)
                              '(1 . "")
                              (cons 7 txt-style)
                              '(100 . "AcDbAttributeDefinition")
                              (cons 3 p-str)
                              (cons 2 (strcase t-str))
                              '(70 . 0)
                        )
                )
                (setq bname (entmake (list '(0 . "ENDBLK") '(100 . "AcDbEntity") (cons 8 lyr) '(100 . "AcDbBlockEnd"))))
        )
      )
      (entmake (list '(0 . "INSERT")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbBlockReference")
                    '(66 . 1)
                    (cons 2 bname)
                    (cons 10 ins-pt)
              )
      )
      (entmake (list '(0 . "ATTRIB")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbText")
                    (cons 10 ins-pt)
                    (cons 40 txt-ht)
                    (cons 1 txt-str)
                    (cons 7 txt-style)
                    (cons 50 rot) ;;; <----
                    '(100 . "AcDbAttribute")
                    (cons 2 t-str)
                    '(70 . 0)
              )
      )
      (entmake '((0 . "SEQEND")))
      (entdel en)
  )
  (princ)
)

Respecto a la posibilidad de que trate también multitextos, dada la gran variedad de colores, marcadores, líneas de texto, etc que pueden albergar, llevaría mucho tiempo y sería complicadillo meterse con ello.
Lo que si se puede hacer es resolver el caso concreto que tu has propuesto en tu dibujo modelo, es decir, fijar constantes  la altura de texto, el número de líneas y el tipo de letra como en tu ejemplo.
Siguiendo la mecánica de la rutina de Tony solo habría que añadir los multitextos a la selección de ssget,  crear una lista de atributos por cada línea y separarlos en altura a la hora de su inserción, con un porcentaje de la altura del texto. Vamos, como sigue :
Código:
; Convierte texto en atributo de bloque.
 ; Program by Tony Hotchkiss
;; añadido ciertos multitextos por Nolo en septiembre 2017
(defun dxf (code ename) (cdr (assoc code (entget ename))))
(defun make-attributes (ss blockname /  i n rot txt txtl tmsg pmsg t-str p-str en ins-pt txt-ht txt-str txt-style lyr btble)
  (setq i    (- 1)
        tmsg  "\nSolicitud: "
        pmsg  (strcat "\nAtributo sin nombrte" " devuelve el mismo que el identificador: ")
        t-str (getstring tmsg)
        p-str (getstring t pmsg)
  )

(if (= t-str "") (setq t-str "Dato ")) ;; por si quieres darle al intro sin poner nada

  (repeat (sslength ss)
      (setq en        (ssname ss (setq i (1+ i)))
            ins-pt    (dxf 10 en)
            txt-ht    (dxf 40 en)
            txt  (dxf 1 en) ;;; aqui era txt-str
            txt-style (dxf 7 en)
            lyr      (dxf 8 en)
 rot (dxf 50 en);;; <----
 n -1
 
      )

(while (wcmatch txt (strcat "*"(chr 10)"*"))
 (setq txt (vl-string-subst  (strcat (chr 34)")("(chr 34)) (chr 10) txt))
)
(setq txtl (eval(read (strcat "'(("(chr 34) txt (chr 34) ")))"))))


      (setq btble (tblsearch "BLOCK" blockname))
      (if (= btble nil)
        (progn (entmake (list '(0 . "BLOCK")
                              '(100 . "AcDbEntity")
                              (cons 8 lyr)
                              '(100 . "AcDbBlockBegin")
                              (cons 2 blockname)
                              '(70 . 2)
                              (cons 10 ins-pt)

                        )
                )
(foreach txt-str txtl
                (entmake (list '(0 . "ATTDEF")
                              '(100 . "AcDbEntity")
                              '(67 . 0)
                              (cons 8 lyr)
                              '(100 . "AcDbText")
                              (cons 10 ins-pt)
                              (cons 40 txt-ht)
                              '(1 . "")
                              (cons 7 txt-style)
                              '(100 . "AcDbAttributeDefinition")
                              (cons 3 p-str)
                              (cons 2 (strcat t-str (itoa (setq n (1+ n)))))
                              '(70 . 0)
                        )
                )
)
               (setq bname (entmake (list '(0 . "ENDBLK") '(100 . "AcDbEntity") (cons 8 lyr) '(100 . "AcDbBlockEnd"))))
        )
      )
(setq n -1)
      (entmake (list '(0 . "INSERT")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbBlockReference")
                    '(66 . 1)
                    (cons 2 bname)
                    (cons 10 ins-pt)
              )
      )

(foreach txt-str txtl
      (entmake (list '(0 . "ATTRIB")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbText")
                    (cons 10
 (if (>(length  txtl) 1)
 (polar ins-pt (* 1.5 pi) (* n (getvar 'textsize) 0.65)) ;; 0.65 porcentaje interlineado
 ins-pt
 ))
                    (cons 40 txt-ht)
                    (cons 1 (car txt-str))
                    (cons 7 txt-style)
 (cons 50 rot) ;;; <----
                    '(100 . "AcDbAttribute")
                    (cons 2 (strcat t-str (itoa (setq n (1+ n)))))
                    '(70 . 0)
              )
      )

); fin foreach

      (entmake '((0 . "SEQEND")))
      (entdel en)
  )
  (princ)
)
(defun c:txt_att (/ block-exists blockname btble ss)
  (setq block-exists t)
  (while block-exists
      (setq blockname (getstring "Nombre de bloque: "))
      (setq btble (tblsearch "BLOCK" blockname))
      (if btble
        (progn (setq block-exists t) (prompt "\nNombre de bloque existente, Enter "))
        (progn (setq block-exists nil))
      )
  )
  (setq ss nil)
  (prompt "\nSeleccionar texto: ")
  (while (= ss nil)
      (setq ss (ssget '((0 . "TEXT,MTEXT"))))
      (if (= ss nil)
        (prompt "\nNingun texto seleccionado, Seleccionar texto: ")
      )
  )
  (if ss
      (progn (make-attributes ss blockname))
  )
)

Si cambias el número de líneas del texto, se mantendrá que el punto de inserción esta en la segunda línea y si cambias tipo de letra tendras que ajustar el valor de los 0.65 de interlineado que te he señalado. Si el multitexto tiene otros parámetros de color, altura etc Se ignorarán o dará resultados extraños.

Espero te sirva ....
Un saludo

nolo

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

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Lun Sep 18, 2017 6:27 am

Hola, nolo, gracias por el tiempo tomado, he podido revizar y para lo que necesito funciona. Esta rutina me ayudara mucho en lo que estoy haciendo.

Una consulta si el MText que puse de ejemplo, tenia 3 filas de texto ahora tuviera cuatro filas. que tendria que adicionar a la rutina para que me genere el bloque con 4 atributos.

Igual muchas gracias por todo el apoyo obtenido.
:-)

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Lun Sep 18, 2017 6:38 am

Hola nolo, te hago una consulta adicional, https:// drive.google.com/open?id=0B3HBbf2wcY4naXNCb3BHcE8tTms
Ojala puedas verlo, ya que si bien es cierto el bloque queda rotado pero ese angulo no lo ingresa al bloque.
Gracias.

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por nolo Lun Sep 18, 2017 3:05 pm

Los atributos tiene rotación y punto de inserción independente del bloque por lo que aunque el bloque este girado xº cuando insertas el atributo hay que ponerle su propia rotación. Una vez insertado, al girar el bloque girara con el.
Es otro procedimiento que se podía haber sequido, insertar en horizontal (tal como estaba) y luego girar el bloque insertado, pero es mas fácil hacerlo de una vez.

La rutina insertará tantos atributos en el bloque como líneas, lo único es que no mantendrá el punto de inserción del texto como referencia y moverá los atributos de forma que quedaran desplazados respecto a la situación original de los textos.

Estos puntos de inserción se pueden corregir en la función polar de las líneas que ponen
Código:
(cons 10
 (if (>(length  txtl) 1)
 (polar ins-pt (* 1.5 pi) (* n (getvar 'textsize) 0.65)) ;; 0.65 serparación
 ins-pt
 ))

Cambiando el if por un condicional que dependa del número de línea n  según de la longitud de la lista de textos txtl o una función mas compleja dependiendo del boundinboox del texto.
Eso te lo dejo para que hagas pruebas y así iras aprendiendo ...

Un saludo

nolo

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

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Mar Sep 19, 2017 2:59 am

Segun Esto "Los atributos tiene rotación y punto de inserción independente del bloque por lo que aunque el bloque este girado xº cuando insertas el atributo hay que ponerle su propia rotación. Una vez insertado, al girar el bloque girara con el.
Es otro procedimiento que se podía haber sequido, insertar en horizontal (tal como estaba) y luego girar el bloque insertado, pero es mas fácil hacerlo de una vez
."
No hay ninguna otra opcion de poder poner el angulo de rotacion, ya que al editar el bloque y synchronize todos los bloques se ponen horizontal.

Ojala puedas apoyarme en esta ultima parte . Gracias ;-)

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por nolo Mar Sep 19, 2017 2:53 pm

Hola, no se lo que quieres decir con - editar el bloque y synchronize -
Con el doble clip a mi me aparece el editor de atributos en los bloques con atributos, y tiene sus propias casillas para la rotación

Texto a Bloque Atributo Editor10

Para girar el bloque después de insertado, esta sería la modificación de la rutina

Código:
(defun make-attributes (ss blockname /  i n  txt txtl tmsg pmsg t-str p-str en ins-pt txt-ht txt-str txt-style lyr btble);;;rot
  (setq i    (- 1)
        tmsg  "\nSolicitud: "
        pmsg  (strcat "\nAtributo sin nombrte" " devuelve el mismo que el identificador: ")
        t-str (getstring tmsg)
        p-str (getstring t pmsg)
  )

(if (= t-str "") (setq t-str "Dato "))

  (repeat (sslength ss)
      (setq en        (ssname ss (setq i (1+ i)))
            ins-pt    (dxf 10 en)
            txt-ht    (dxf 40 en)
            txt  (dxf 1 en) ;;; aqui era txt-str
            txt-style (dxf 7 en)
            lyr      (dxf 8 en)
 rot (dxf 50 en);;; <----
 n -1
 
      )

(while (wcmatch txt (strcat "*"(chr 10)"*"))
 (setq txt (vl-string-subst  (strcat (chr 34)")("(chr 34)) (chr 10) txt))
)
(setq txtl (eval(read (strcat "'(("(chr 34) txt (chr 34) ")))"))))


      (setq btble (tblsearch "BLOCK" blockname))
      (if (= btble nil)
        (progn (entmake (list '(0 . "BLOCK")
                              '(100 . "AcDbEntity")
                              (cons 8 lyr)
                              '(100 . "AcDbBlockBegin")
                              (cons 2 blockname)
                              '(70 . 2)
                              (cons 10 ins-pt)

                        )
                )
(foreach txt-str txtl
                (entmake (list '(0 . "ATTDEF")
                              '(100 . "AcDbEntity")
                              '(67 . 0)
                              (cons 8 lyr)
                              '(100 . "AcDbText")
                              (cons 10 ins-pt)
                              (cons 40 txt-ht)
                              '(1 . "")
                              (cons 7 txt-style)
                              '(100 . "AcDbAttributeDefinition")
                              (cons 3 p-str)
                              (cons 2 (strcat t-str (itoa (setq n (1+ n)))))
                              '(70 . 0)
                        )
                )
)
               (setq bname (entmake (list '(0 . "ENDBLK") '(100 . "AcDbEntity") (cons 8 lyr) '(100 . "AcDbBlockEnd"))))
        )
      )
(setq n -1)
      (entmake (list '(0 . "INSERT")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbBlockReference")
                    '(66 . 1)
                    (cons 2 bname)
                    (cons 10 ins-pt)
              )
      )

(foreach txt-str txtl
      (entmake (list '(0 . "ATTRIB")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbText")
                    (cons 10
 (if (>(length  txtl) 1)
 (polar ins-pt (* 1.5 pi) (* n (getvar 'textsize) 0.65)) ;; 0.65 serparación
 ins-pt
 ))
                    (cons 40 txt-ht)
                    (cons 1 (car txt-str))
                    (cons 7 txt-style)
 ;;;(cons 50 rot) ;;; <----
                    '(100 . "AcDbAttribute")
                    (cons 2 (strcat t-str (itoa (setq n (1+ n)))))
                    '(70 . 0)
              )
      )

); fin foreach

      (entmake '((0 . "SEQEND")))
      (entdel en)


;; rotación al bloque

(setq obl (vlax-ename->vla-object (entlast)))
(VLA-PUT-ROTATION obl rot)

  )
  (princ)
)

Un saludo

nolo

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

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Jue Sep 21, 2017 12:24 am

Hola amigo, disculpa todavia no se mucho de programar, pero como enlazo este ultimo codigo con el anterior.
Para poder ejecutarlo.
Gracias

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por nolo Jue Sep 21, 2017 11:06 am

Solo tienes que cambiar la función make-atributes antigua por la nueva de mi anterior post.
Entre el (defun make-attributes etc ....
y el
 (princ)
)

Así sería el cambio
Código:
; Convierte texto en atributo de bloque.
 ; Program by Tony Hotchkiss
;; añadido ciertos multitextos por Nolo en septiembre 2017
(defun dxf (code ename) (cdr (assoc code (entget ename))))
(defun make-attributes (ss blockname /  i n  txt txtl tmsg pmsg t-str p-str en ins-pt txt-ht txt-str txt-style lyr btble);;;rot
  (setq i    (- 1)
        tmsg  "\nSolicitud: "
        pmsg  (strcat "\nAtributo sin nombrte" " devuelve el mismo que el identificador: ")
        t-str (getstring tmsg)
        p-str (getstring t pmsg)
  )

(if (= t-str "") (setq t-str "Dato "))

  (repeat (sslength ss)
      (setq en        (ssname ss (setq i (1+ i)))
            ins-pt    (dxf 10 en)
            txt-ht    (dxf 40 en)
            txt  (dxf 1 en) ;;; aqui era txt-str
            txt-style (dxf 7 en)
            lyr      (dxf 8 en)
 rot (dxf 50 en);;; <----
 n -1
 
      )

(while (wcmatch txt (strcat "*"(chr 10)"*"))
 (setq txt (vl-string-subst  (strcat (chr 34)")("(chr 34)) (chr 10) txt))
)
(setq txtl (eval(read (strcat "'(("(chr 34) txt (chr 34) ")))"))))


      (setq btble (tblsearch "BLOCK" blockname))
      (if (= btble nil)
        (progn (entmake (list '(0 . "BLOCK")
                              '(100 . "AcDbEntity")
                              (cons 8 lyr)
                              '(100 . "AcDbBlockBegin")
                              (cons 2 blockname)
                              '(70 . 2)
                              (cons 10 ins-pt)

                        )
                )
(foreach txt-str txtl
                (entmake (list '(0 . "ATTDEF")
                              '(100 . "AcDbEntity")
                              '(67 . 0)
                              (cons 8 lyr)
                              '(100 . "AcDbText")
                              (cons 10 ins-pt)
                              (cons 40 txt-ht)
                              '(1 . "")
                              (cons 7 txt-style)
                              '(100 . "AcDbAttributeDefinition")
                              (cons 3 p-str)
                              (cons 2 (strcat t-str (itoa (setq n (1+ n)))))
                              '(70 . 0)
                        )
                )
)
               (setq bname (entmake (list '(0 . "ENDBLK") '(100 . "AcDbEntity") (cons 8 lyr) '(100 . "AcDbBlockEnd"))))
        )
      )
(setq n -1)
      (entmake (list '(0 . "INSERT")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbBlockReference")
                    '(66 . 1)
                    (cons 2 bname)
                    (cons 10 ins-pt)
              )
      )

(foreach txt-str txtl
      (entmake (list '(0 . "ATTRIB")
                    '(100 . "AcDbEntity")
                    (cons 8 lyr)
                    '(100 . "AcDbText")
                    (cons 10
 (if (>(length  txtl) 1)
 (polar ins-pt (* 1.5 pi) (* n (getvar 'textsize) 0.65)) ;; 0.65 serparación
 ins-pt
 ))
                    (cons 40 txt-ht)
                    (cons 1 (car txt-str))
                    (cons 7 txt-style)
 ;;;(cons 50 rot) ;;; <----
                    '(100 . "AcDbAttribute")
                    (cons 2 (strcat t-str (itoa (setq n (1+ n)))))
                    '(70 . 0)
              )
      )

); fin foreach

      (entmake '((0 . "SEQEND")))
      (entdel en)


;; rotación al bloque

(setq obl (vlax-ename->vla-object (entlast)))
(VLA-PUT-ROTATION obl rot)

  )
  (princ)
)
(defun c:txt_att (/ block-exists blockname btble ss)
  (setq block-exists t)
  (while block-exists
      (setq blockname (getstring "Nombre de bloque: "))
      (setq btble (tblsearch "BLOCK" blockname))
      (if btble
        (progn (setq block-exists t) (prompt "\nNombre de bloque existente, Enter "))
        (progn (setq block-exists nil))
      )
  )
  (setq ss nil)
  (prompt "\nSeleccionar texto: ")
  (while (= ss nil)
      (setq ss (ssget '((0 . "TEXT,MTEXT"))))
      (if (= ss nil)
        (prompt "\nNingun texto seleccionado, Seleccionar texto: ")
      )
  )
  (if ss
      (progn (make-attributes ss blockname))
  )
)

Un saludo

nolo

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

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

Mensaje por SushyM Jue Sep 21, 2017 11:28 pm

Muchas Gracias amigo nolo. Funciona a la perfeccion.
;-)

SushyM

Mensajes : 38
Fecha de inscripción : 13/09/2017

Volver arriba Ir abajo

Texto a Bloque Atributo Empty Re: Texto a Bloque Atributo

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.