Newsgroup: it.comp.software.cad
Titolo: Ho bisogno di un lisp che scali + testi contemporaneamente

E che li scali, mantenendo la posizione dell loro punto di
inserimento.
grazie a tutti
Ciao da X-file

 Ciao da X-file
Non c'è di che'
Ciao
Hiryu


Ciao da X-file

 punto di inserimento. Tutti della metà o di un altro fattore.
Mi perdoni il taglincollaggio?
Hai un po di pazienza?
Se le tue risposte sono (Si Si)
Attendi qualche gg e lo avrai, volevo farlo pure per me,
cosi' colgo l'occasione e lo faccio.
Ciao Giovanni Anzani


Ciao da X-file.


E' inutile che ti metti a fare cose che la Autodesk ha già distribuito da
anni.
CHT.LSP lo allego di seguito.
;;;   CHTEXT.LSP
;;;   (C) Copyright 1988-1993 by Autodesk, Inc.
;;;
;;;   This program is copyrighted by Autodesk, Inc. and is  licensed
;;;   to you under the following conditions.  You may not distribute
;;;   or  publish the source code of this program in any form.   You
;;;   may  incorporate this code in object form in derivative  works
;;;   provided  such  derivative  works  are  (i.) are  designed and
;;;   intended  to  work  solely  with  Autodesk, Inc. products, and
;;;   (ii.)  contain  Autodesk's  copyright  notice  "(C)  Copyright
;;;   1988-1993 by Autodesk, Inc."
;;;
;;;   AUTODESK  PROVIDES THIS PROGRAM "AS IS" AND WITH  ALL  FAULTS.
;;;   AUTODESK  SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF  MER-
;;;   CHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK,  INC.
;;;   DOES  NOT  WARRANT THAT THE OPERATION OF THE PROGRAM  WILL  BE
;;;   UNINTERRUPTED OR ERROR FREE.
;;;
;;;   by Jan S. Yoder
;;;   09 March  1990
;;;
;;;   REVISIONS
;;;   1.01  22 May 1991  DTP -- Minor bug fixes.
;;;   1.02  18 June 1991  JSY, DTP -- Minor bug fixes.
;;;
;;;-------------------------------------------------------------------------
-;
;;; DESCRIPTION
;;;   This is a "text processor" which operates in a global manner
;;;   on all of the text entities that the user selects; i.e., the
;;;   Height, Justification, Location, Rotation, Style, Text, and
;;;   Width can all be changed globally or individually, and the
;;;   range of values for a given parameter can be listed.
;;;
;;;   The command is called with CHT from the command line at which
;;;   time the user is asked to select the objects to change.
;;;
;;;     Select text to change.
;;;     Select objects:
;;;
;;;   If nothing is selected the message "ERROR: Nothing selected."
;;;   is displayed and the command is terminated.  If more than 25
;;;   entities are selected the following message is displayed while
;;;   the text entities are sorted out from the non-text entities.
;;;   A count of the text entities found is then displayed.
;;;
;;;     Verifying the selected entities -- please wait.
;;;     nnn  text entities found.
;;;     CHText:
Height/Justification/Location/Rotation/Style/Text/Undo/Width:
;;;
;;;   A typical example of the prompts you may encounter follows:
;;;
;;;   If you select a single text entity to change and ask to change
;;;   the height, the prompt looks like this:
;;;
;;;     CHText:
Height/Justification/Location/Rotation/Style/Text/Undo/Width:
;;;     New text height for text entity. <0.08750000>:
;;;
;;;   If you select more than one text entity to change and ask to change
;;;   the height, the prompt looks like this:
;;;
;;;     CHText:
Height/Justification/Location/Rotation/Style/Text/Undo/Width:
;;;     Individual/List/<New height for all entities>:
;;;
;;;   Typing "L" at this prompt returns a prompt showing you the range of
;;;   values that you are using for your text.
;;;
;;;     Height -- Min: 0.05000000  Max: 0.10000000  Ave: 0.08392857
;;;
;;;   Typing "I" at this prompt puts you in a loop, processing the text
;;;   entities you have selected one at a time, and giving the same prompt
;;;   you get for a single text entity shown above.
;;;
;;;   Pressing RETURN at this point puts you back at the Command: prompt.
;;;   Selecting any of the other options allows you to change the text
;;;   entities selected.
;;;
;;;   All of the Release 11 text alignment options have been supported.
;;;   This is based on the system variable "DIMCLRD" being present.
;;;   If it is not present, then only the  Release 10 alignment options
;;;   are allowed.
;;;
;;;-------------------------------------------------------------------------
--;
;;;
;;; Main function -- no arguments
;;;
(defun chtxt (/ sset opt ssl nsset temp unctr ct_ver cht_er cht_oe
                sslen style hgt rot txt ent cht_oc cht_ot cht_oh
                loc loc1 justp justq orthom )
  (setq ct_ver "1.02")                ; Reset this local if you make a
change.
  ;;
  ;; Internal error handler defined locally
  ;;
  (defun cht_er (s)                   ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
    (if (/= s "Function cancelled")
      (if (= s "quit / exit abort")
        (princ)
        (princ (strcat "\nErrore: " s))
      )
    )
    (eval(read U:E))
    (if cht_oe                        ; If an old error routine exists
      (setq *error* cht_oe)           ; then, reset it
    )
    (if temp (redraw temp 1))
    (if cht_oc (setvar "cmdecho" cht_oc)) ; Reset command echoing
    (if cht_ot (setvar "texteval" cht_ot))
    (if cht_oh (setvar "highlight" cht_oh))
    (princ)
  )
  ;;
  ;; Body of function
  ;;
  (if *error*                         ; Set our new error handler
    (setq cht_oe *error* *error* cht_er)
    (setq *error* cht_er)
  )
  ;; Set undo groups and ends with (eval(read U:G)) or (eval(read U:E))
  (setq U:G "(command \"_.undo\" \"_group\")"
        U:E "(command \"_.undo\" \"_en\")"
  )
  (setq cht_oc (getvar "cmdecho"))
  (setq cht_oh (getvar "highlight"))
  (setvar "cmdecho" 0)
  (eval(read U:G))
  (princ (strcat "\nCHTEXT, Versione " ct_ver
                 ", (c) 1990-1993 Autodesk, Inc. "))
  (prompt "\nSelezionare il testo da cambiare. ")
  (setq sset (ssget))
  (if (null sset)
    (progn
      (princ "\nERRORE: Nessuna selezione.")
      (exit)
    )
  )
  ;; Verify the entity set.
  (cht_ve)
  ;; This is the main option loop.
  (cht_ol)
  (if cht_oe (setq *error* cht_oe))   ; Reset old error function if error
  (eval(read U:E))
  (if cht_ot (setvar "texteval" cht_ot))
  (if cht_oh (setvar "highlight" cht_oh))
  (if cht_oc (setvar "cmdecho" cht_oc)) ; Reset command echoing
  (princ)
)
;;;
;;; Verify and sort out non-text entities from the selection set.
;;;
(defun cht_ve ()
  (setq ssl   (sslength sset)
        nsset (ssadd))
  (if (> ssl 25)
    (princ "\nVerifica delle entit. selezionate -- Attendere prego. ")
  )
  (while (> ssl 0)
    (setq temp (ssname sset (setq ssl (1- ssl))))
    (if (= (cdr(assoc 0 (entget temp))) "TEXT")
      (ssadd temp nsset)
    )
  )
  (setq ssl (sslength nsset)
        sset nsset
        unctr 0
  )
  (princ (strcat "Trovata(e) " (rtos ssl 2 0) " entit. di tipo testo. "))
)
;;;
;;; The option loop.
;;;
(defun cht_ol ()
  (setq opt T)
  (while (and opt (> ssl 0))
    (setq unctr (1+ unctr))
    (command "_.UNDO" "_GROUP")
    (initget "LOcazione Giustificazione Stile ALtezza Rotazione LArghezza
Testo ANnulla")
    (setq opt (getkword
"\nALtezza/Giustificazione/LOcazione/Rotazione/Stile/Testo/ANnulla/LArghezza
: "))
    (if opt
      (cond
        ((= opt "ANnulla")
          (cht_ue)                    ; Undo the previous command.
        )
        ((= opt "LOcazione")
          (cht_le)                    ; Change the location.
        )
        ((= opt "Giustificazione")
          (cht_je)                    ; Change the justification.
        )
        ((= opt "Stile")    (cht_pe "Stile"    "nome stile"      7) )
        ((= opt "ALtezza")   (cht_pe "ALtezza"   "valore dell'altezza"
40) )
        ((= opt "Rotazione") (cht_pe "Rotazione" "angolo di rotazione" 50) )
        ((= opt "LArghezza")    (cht_pe "LArghezza"    "fattore di
larghezza"   41) )
        ((= opt "Testo")
          (cht_te)                    ; Change the text.
        )
      )
      (setq opt nil)
    )
    (command "_.UNDO" "_END")
  )
)
;;;
;;; Undo an entry.
;;;
(defun cht_ue ()
  (if (> unctr 1)
    (progn
      (command "_.UNDO" "_END")
      (command "_.UNDO" "2")
      (setq unctr (- unctr 2))
    )
    (progn
      (princ "\nNon S stato trovato niente da annullare. ")
      (setq unctr (- unctr 1))
    )
  )
)
;;;
;;; Change the location of an entry.
;;;
(defun cht_le ()
  (setq sslen (sslength sset)
        style ""
        hgt   ""
        rot   ""
        txt   ""
  )
  (command "_.CHANGE" sset "" "")
  (while (> sslen 0)
    (setq ent (entget(ssname sset (setq sslen (1- sslen))))
          opt (list (cadr (assoc 11 ent))
                    (caddr (assoc 11 ent))
                    (cadddr (assoc 11 ent)))
    )
    (prompt "\nNuova locazione del testo: ")
    (command pause)
    (if (null loc)
      (setq loc opt)
    )
    (command style hgt rot txt)
  )
  (command)
)
;;;
;;; Change the justification of an entry.
;;;
(defun cht_je ()
  (if (getvar "DIMCLRD")
    (initget (strcat "ASinistra ACentro ADestra "
                     "MSinistra MCentro MDestra "
                     "BSinistra BCentro BDestra "
                     "Proporzionale Centro Adatta Sinistra Mezzo Destra ?"))
    (initget "Proporzionale Centro Adatta Sinistra Mezzo Destra ?")
  )
  (setq sslen (sslength sset))
  (setq justp (getkword (strcat "\nModalit. di allineamento: "
              "\nProporzionale/Centro/Fisso/Sinistra/Mezzo/Destra/<?>: ")))
  (cond
    ((= justp "Sinistra")    (setq justp 0 justq 0) )
    ((= justp "Centro")  (setq justp 1 justq 0) )
    ((= justp "Destra")   (setq justp 2 justq 0) )
    ((= justp "Proporzionale") (setq justp 3 justq 0) )
    ((= justp "Adatta")     (setq justp 5 justq 0) )
    ((= justp "ASinistra")   (setq justp 0 justq 3) )
    ((= justp "ACentro") (setq justp 1 justq 3) )
    ((= justp "ADestra")  (setq justp 2 justq 3) )
    ((= justp "MSinistra")   (setq justp 0 justq 2) )
    ((= justp "Mezzo")  (setq justp 4 justq 0) )
    ((= justp "MCentro") (setq justp 1 justq 2) )
    ((= justp "MDestra")  (setq justp 2 justq 2) )
    ((= justp "BSinistra")   (setq justp 0 justq 1) )
    ((= justp "BCentro") (setq justp 1 justq 1) )
    ((= justp "BDestra")  (setq justp 2 justq 1) )
    ((= justp "?")       (setq justp nil)       )
    (T                   (setq justp nil)       )
  )
  (if justp
    (justpt) ; Process them...
    (justpn) ; List options...
  )
  (command)
)
;;;
;;; Get alignment points for "aligned" or "fit" text.
;;;
(defun justpt ()
  (while (> sslen 0)
    (setq ent (entget(ssname sset (setq sslen (1- sslen))))
          ent (subst (cons 72 justp) (assoc 72 ent) ent)
          opt (trans (list (cadr (assoc 11 ent))
                           (caddr (assoc 11 ent))
                           (cadddr (assoc 11 ent)))
                     (cdr(assoc -1 ent)) ; from ECS
                     1)               ; to current UCS
    )
    (if (getvar "DIMCLRD")
      (setq ent (subst (cons 73 justq) (assoc 73 ent) ent))
    )
    (cond
      ((or (= justp 3) (= justp 5))
        (prompt "\nNuovi punti di allineamento del testo: ")
        (if (= (setq orthom (getvar "orthomode")) 1)
          (setvar "orthomode" 0)
        )
        (redraw (cdr(assoc -1 ent)) 3)
        (initget 1)
        (setq loc (getpoint))
        (initget 1)
        (setq loc1 (getpoint loc))
        (redraw (cdr(assoc -1 ent)) 1)
        (setvar "orthomode" orthom)
        (setq ent (subst (cons 10 loc) (assoc 10 ent) ent))
        (setq ent (subst (cons 11 loc1) (assoc 11 ent) ent))
      )
      ((or (/= justp 0) (/= justq 0))
        (redraw (cdr(assoc -1 ent)) 3)
        (prompt "\nNuova locazione del testo: ")
        (if (= (setq orthom (getvar "orthomode")) 1)
          (setvar "orthomode" 0)
        )
        (setq loc (getpoint opt))
        (setvar "orthomode" orthom)
        (redraw (cdr(assoc -1 ent)) 1)
        (if (null loc)
          (setq loc opt)
          (setq loc (trans loc 1 (cdr(assoc -1 ent))))
        )
        (setq ent (subst (cons 11 loc) (assoc 11 ent) ent))
      )
    )
    (entmod ent)
  )
)
;;;
;;; List the options.
;;;
(defun justpn ()
  (if (getvar "DIMCLRD") (textpage))
  (princ "\nOpzioni di Allineamento: ")
  (princ "\n\t ASinistra   ACentro   ADestra ")
  (princ "\n\t MSinistra   MCentro   MDestra ")
  (princ "\n\t BSinistra   BCentro   BDestra ")
  (princ "\n\t Sinistra    Centro    Destra")
  (princ "\n\t Proporzion. Mezzo     Adatta")
  (if (not (getvar "DIMCLRD")) (textscr))
  (princ "\n\nPremere qualsiasi tasto per tornare al disegno. ")
  (grread)
  (princ "\r                                           ")
  (graphscr)
)
;;;
;;; Change the text of an entity.
;;;
(defun cht_te ()
  (setq sslen (sslength sset))
  (initget "Globale Individuale Ridigitare")
  (setq ans (getkword
    "\nRicerca e sostituzione testo.  Individuale/Ridigitare/<Globale>:"))
  (setq cht_ot (getvar "texteval"))
  (setvar "texteval" 1)
  (cond
    ((= ans "Individuale")
      (if (= (getvar "popups") 1)
        (progn
          (initget "Si No")
          (setq ans (getkword "\nEditare il testo nel riquadro di dialogo?
<S>:"))
        )
        (setq ans "No")
      )
      (while (> sslen 0)
        (redraw (setq sn (ssname sset (setq sslen (1- sslen)))) 3)
        (setq ss (ssadd))
        (ssadd (ssname sset sslen) ss)
        (if (= ans "No")
          (chgtext ss)
          (command "_.DDEDIT" sn "")
        )
        (redraw sn 1)
      )
    )
    ((= ans "Ridigitare")
      (while (> sslen 0)
        (setq ent (entget(ssname sset (setq sslen (1- sslen)))))
        (redraw (cdr(assoc -1 ent)) 3)
        (prompt (strcat "\nVecchio testo: " (cdr(assoc 1 ent))))
        (setq nt (getstring  T "\nNuovo testo: "))
        (redraw (cdr(assoc -1 ent)) 1)
        (if (> (strlen nt) 0)
          (entmod (subst (cons 1 nt) (assoc 1 ent) ent))
        )
      )
    )
    (T
      (chgtext sset)                  ; Change 'em all
    )
  )
  (setvar "texteval" cht_ot)
)
;;;
;;; The old CHGTEXT command - rudimentary text editor
;;;
;;;
(defun C:CHGTEXT () (chgtext nil))
(defun chgtext (objs / last_o tot_o ent o_str n_str st s_temp
                       n_slen o_slen si chf chm cont ans)
  (if (null objs)
    (setq objs (ssget))               ; Select objects if running standalone
  )
  (setq chm 0)
  (if objs
    (progn                   ; If any objects selected
      (if (= (type objs) 'ENAME)
        (progn
          (setq ent (entget objs))
          (princ (strcat "\nStringa esistente: " (cdr (assoc 1 ent))))
        )
        (if (= (sslength objs) 1)
          (progn
            (setq ent (entget (ssname objs 0)))
            (princ (strcat "\nStringa esistente: " (cdr (assoc 1 ent))))
          )
        )
      )
      (setq o_str (getstring "\nStringa da cambiare   : " t))
      (setq o_slen (strlen o_str))
      (if (/= o_slen 0)
        (progn
          (setq n_str (getstring "\nStringa nuova     : " t))
          (setq n_slen (strlen n_str))
          (setq last_o 0
                tot_o  (if (= (type objs) 'ENAME)
                         1
                         (sslength objs)
                       )
          )
          (while (< last_o tot_o)     ; For each selected object...
            (if (= "TEXT"             ; Look for TEXT entity type (group 0)
                   (cdr (assoc 0 (setq ent (entget (ssname objs last_o))))))
              (progn
                (setq chf nil si 1)
                (setq s_temp (cdr (assoc 1 ent)))
                (while (= o_slen (strlen (setq st (substr s_temp si
o_slen))))
                  (if (= st o_str)
                    (progn
                      (setq s_temp (strcat
                                     (if (> si 1)
                                       (substr s_temp 1 (1- si))
                                       ""
                                     )
                                     n_str
                                     (substr s_temp (+ si o_slen))
                                   )
                      )
                      (setq chf t)    ; Found old string
                      (setq si (+ si n_slen))
                    )
                    (setq si (1+ si))
                  )
                )
                (if chf
                  (progn              ; Substitute new string for old
                    ; Modify the TEXT entity
                    (entmod (subst (cons 1 s_temp) (assoc 1 ent) ent))
                    (setq chm (1+ chm))
                  )
                )
              )
            )
            (setq last_o (1+ last_o))
          )
        )
        ;; else go on to the next line...
      )
    )
  )
  (if (/= (type objs) 'ENAME)
    (if (/= (sslength objs) 1)        ; Print total lines changed
      (princ (strcat "Cambiate "
                     (rtos chm 2 0)
                     " righe di testo."
             )
      )
    )
  )
  (terpri)
)
;;;
;;; Main procedure for manipulating text entities
;;; ARGUMENTS:
;;;   typ   -- Type of operation to perform
;;;   prmpt -- Partial prompt string to insert in standard prompt line
;;;   fld   -- Assoc field to be changed
;;; GLOBALS:
;;;   sset  -- The selection set of text entities
;;;
(defun cht_pe (typ prmpt fld / temp ow nw ent tw sty w hw lw
                              sslen n sn ssl)
  (if (= (sslength sset) 1)           ; Special case if there is only
                                      ; one entity selected
    ;; Process one entity.
    (cht_p1)
    ;; Else
    (progn
      ;; Set prompt string.
      (cht_sp)
      (if (= nw "Elenco")
        ;; Process List request.
        (cht_pl)
        (if (= nw "Individuale")
          ;; Process Individual request.
          (cht_pi)
          (if (= nw "Selezionare")
            ;; Process Select request.
            (cht_ps)
            ;; Else
            (progn
              (if (= typ "Rotazione")
                (setq nw (* (/ nw 180.0) pi))
              )
              (if (= (type nw) 'STR)
                (if (not (tblsearch "style" nw))
                  (progn
                    (princ (strcat "\nStile " nw " non trovato. "))
                  )
                  (cht_pa)
                )
                (cht_pa)
              )
            )
          )
        )
      )
    )
  )
)
;;;
;;; Change all of the entities in the selection set.
;;;
(defun cht_pa (/ cht_oh temp)
  (setq sslen (sslength sset))
  (setq cht_oh (getvar "highlight"))
  (setvar "highlight" 0)
  (while (> sslen 0)
    (setq temp (ssname sset (setq sslen (1- sslen))))
    (entmod (subst (cons fld nw)
                   (assoc fld (setq ent (entget temp)))
                   ent
            )
    )
  )
  (setvar "highlight" cht_oh)
)
;;;
;;; Change one text entity.
;;;
(defun cht_p1 ()
  (setq temp (ssname sset 0))
  (setq ow (cdr(assoc fld (entget temp))))
  (if (= opt "Rotazione")
    (setq ow (/ (* ow 180.0) pi))
  )
  (redraw (cdr(assoc -1 (entget temp))) 3)
  (initget 0)
  (if (= opt "Stile")
    (setq nw (getstring (strcat "\nNuovo " prmpt ". <"
                              ow ">: ")))
    (setq nw (getreal (strcat "\nNuovo " prmpt ". <"
                              (rtos ow 2) ">: ")))
  )
  (if (or (= nw "") (= nw nil))
    (setq nw ow)
  )
  (redraw (cdr(assoc -1 (entget temp))) 1)
  (if (= opt "Rotazione")
    (setq nw (* (/ nw 180.0) pi))
  )
  (if (= opt "Stile")
    (if (null (tblsearch "style" nw))
      (princ (strcat "\nStile " nw " non trovato. "))
      (entmod (subst (cons fld nw)
                     (assoc fld (setq ent (entget temp)))
                     ent
              )
      )
    )
    (entmod (subst (cons fld nw)
                   (assoc fld (setq ent (entget temp)))
                   ent
            )
    )
  )
)
;;;
;;; Set the prompt string.
;;;
(defun cht_sp ()
  (if (= typ "Stile")
    (progn
      (initget "Individuale Elenco Nuovo Selezionare ")
      (setq nw (getkword (strcat "\nIndividuale/Elenco/Selezionare
stile/<Nuovo "
                                 prmpt
                                 " per tutte le entit.>: ")))
      (if (or (= nw "") (= nw nil) (= nw "Enter"))
        (setq nw (getstring (strcat "\nNuovo "
                                    prmpt
                                    " per tutte le entit. testo: ")))
      )
    )
    (progn
      (initget "Elenco Individuale" 1)
      (setq nw (getreal (strcat "\nIndividuale/Elenco/<Nuovo "
                                 prmpt
                                 " per tutte le entit. testo>: ")))
    )
  )
)
;;;
;;; Process List request.
;;;
(defun cht_pl ()
  (setq unctr (1- unctr))
  (setq sslen (sslength sset))
  (setq tw 0)
  (while (> sslen 0)
    (setq temp (ssname sset (setq sslen (1- sslen))))
    (if (= typ "Stile")
      (progn
        (if (= tw 0)
          (setq tw (list (cdr(assoc fld (entget temp)))))
          (progn
            (setq sty (cdr(assoc fld (entget temp))))
            (if (not (member sty tw))
              (setq tw (append tw (list sty)))
            )
          )
        )
      )
      (progn
        (setq tw (+ tw (setq w (cdr(assoc fld (entget temp))))))
        (if (= (sslength sset) (1+ sslen)) (setq lw w hw w))
        (if (< hw w) (setq hw w))
        (if (> lw w) (setq lw w))
      )
    )
  )
  (if (= typ "Rotazione")
    (setq tw (* (/ tw pi) 180.0)
          lw (* (/ lw pi) 180.0)
          hw (* (/ hw pi) 180.0))
  )
  (if (= typ "Stile")
    (progn
      (princ (strcat "\n"
                     typ
                     "(s) -- "))
      (princ tw)
    )
    (princ (strcat "\n"
                     typ
                     " -- Minima: "
                     (rtos lw 2)
                     "\t Massima: "
                     (rtos hw 2)
                     "\t Media: "
                     (rtos (/ tw (sslength sset)) 2) ))
  )
)
;;;
;;; Process Individual request.
;;;
(defun cht_pi ()
  (setq sslen (sslength sset))
  (while (> sslen 0)
    (setq temp (ssname sset (setq sslen (1- sslen))))
    (setq ow (cdr(assoc fld (entget temp))))
    (if (= typ "Rotazione")
      (setq ow (/ (* ow 180.0) pi))
    )
    (initget 0)
    (redraw (cdr(assoc -1 (entget temp))) 3)
    (if (= typ "Stile")
      (progn
        (setq nw (getstring (strcat "\nNuovo "
                                   prmpt
                                   ". <"
                                   ow ">: ")))
      )
      (progn
        (setq nw (getreal (strcat "\nNuovo "
                                   prmpt
                                   ". <"
                                (rtos ow 2) ">: ")))
      )
    )
    (if (or (= nw "") (= nw nil))
      (setq nw ow)
    )
    (if (= typ "Rotazione")
      (setq nw (* (/ nw 180.0) pi))
    )
    (entmod (subst (cons fld nw)
                   (assoc fld (setq ent (entget temp)))
                   ent
            )
    )
    (redraw (cdr(assoc -1 (entget temp))) 1)
  )
)
;;;
;;; Process the Select option.
;;;
(defun cht_ps ()
  (princ "\nRicerca dello stile ?  <*>: ")
  (setq sn  (strcase (getstring))
        n   -1
        nsset (ssadd)
        ssl (1- (sslength sset))
        )
  (if (or (= sn "*") (null sn) (= sn ""))
    (setq nsset sset sn "*")
    (while (and sn (< n ssl))
      (setq temp (ssname sset (setq n (1+ n))))
      (if (= (cdr(assoc 7 (entget temp))) sn)
        (ssadd temp nsset)
      )
    )
  )
  (setq ssl (sslength nsset))
  (princ "\nTrovate ")
  (princ ssl)
  (princ " entit. di testo con STILE=")
  (princ sn)
  (princ ". ")
)
;;;
;;; The C: function definition.
;;;
(defun c:cht    () (chtxt))
(princ "  C:CHTEXT caricato.  Usare CHT.")
(princ)

Ciao Massimo,
che bello usi il TAG!
Non conoscevo, credo tale lisp (nel senso che magari e' un bonus o un
express che uso),
lo provero', ma sei sicuro che permette di scalare i testi di un fattore
di scala rispetto al loro punto di inserimento, indipendentemente
dall'altezza del testo settato per ciascuno di essi?
In altre parole sei sicuro che non funzioni solo per testi di altezza
omogenea,
o che il risultato di operazioni effettuate con tale lisp sia composto
di testi alti tutti uguali?
In altre parole, credi che sia possibile dare un altezza percentuale e non
assoluta?
Pero' anche se non facesse per il caso in oggetto tale lisp mi puo' essere
utile
per mettere a punto quello richiesto.
Piu' che altro mi sembra molto lungo, io mi figuravo gia' di fare poche
righe...
ora vedo un po'
Ciao Giovanni Anzani

 ora vedo un po'
Vedi, Vedi


Ho 'veduto' io nel frattempo. Ho impiegato almeno un giorno ma ci sono
riuscto a scriverlo io un lispino.
Esattamente come serviva a X-file (comunque lo userò anch'io)
Eccolo:
;;;;;;;;;;;;;;;;;;;;;;;;;BOF;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; SCT ;;;;;;;;;;SCala Testi;;;;;;;;; by Massimo Ghio
;;; Scala i testi di un determinato fattore senza spostare il punto di
inserimento
(defun c:sct ( / l_imm ent datent cont ent al fs)
 (princ "Selezionare I TESTI DA SCALARE..\n")
 (setq l_imm (ssget (list (cons 0 "TEXT"))))
 (SETQ fs (GETREAL "Fattore di scala :"))
 (if l_imm (progn
   (setq lung (sslength l_imm))
   (setq cont 0)
   (repeat lung
    (setq ent (ssname l_imm cont))
    (setq datent (entget ent))
    (setq al (cdr (assoc 40 datent)))
    (command "_change" ent "" "" "" ""  (*  al fs) "" "")
    (setq cont (+ 1 cont))
    )
   )
 )
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;EOF;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 Lui a me e anche tanti altri, probabilmente.
mah, io intanto ho fatto una cosa per conto suo, male che vada bisognera'
ricordarsi
di usare STI nel caso in oggetto.
poi non so se e' il caso di modificare codice autodesk, magari non
gradiscono. :-)
tra l'altro dicevano:
"You may not distribute or  publish the source code of this program in any
form."
che per il poco che capisco d'inglese non promette nulla di buono.
diciamo che ciascuno (non) se lo incolla a casa sua?  :-)
e che se non e' capace impara? che non fa male?
Ciao Giovanni Anzani
;---CUT---CUT---CUT---CUT---CUT---CUT---CUT---CUT---
;-------------------------------------------------------------------------
; Procedura sviluppata da Giovanni Anzani  -  
giova...@tiscalinet.it
; SET 2001
;-------------------------------------------------------------------------
(defun c:sti (/ sstxt sca cont §1 §2 §3a §3b §4 §5 §6)
(setq §1  "\nSTI: Scalatura dei Testi rispetto al punto d'Inserimento."
      §2  "\n (eventuali selezioni di oggetti che non siano testi verranno
automaticamente scartate): "
      §3a "\n Verranno scalati i "
      §3b " testi preselezionati."
      §4  "\n Selezionare i testi da scalare: "
      §5  "\n Fattore di scala di cui scalare i testi selezionati: "
      §6  "\n Nessun testo selezionato, la procedura verra' interrotta.")
 (setq sstxt (ssget "_i" '((0 . "TEXT"))))
 (mapcar 'princ (list §1 §2))
 (if sstxt (mapcar 'princ (list §3a (sslength sstxt) §3b))
           (progn (princ §4) (setq sstxt (ssget '((0 . "TEXT"))))))
 (initget 7) (setq sca (getreal §5))
 (setq cont 0)
 (if sstxt
  (repeat (sslength sstxt)
    (setq nametxt (ssname sstxt cont)
          PTintxt (cdr (assoc 10 (entget nametxt))))
    (setq cont (1+ cont))
    (command  "_.scale" nametxt "" PTintxt sca))
  (princ §6)))
;-------------------------------------------------------------------------
;---CUT---CUT---CUT---CUT---CUT---CUT---CUT---CUT---

 Lui a me e anche tanti altri, probabilmente.
mah, io intanto ho fatto una cosa per conto suo, male che vada bisognera'
ricordarsi
di usare STI nel caso in oggetto.
poi non so se e' il caso di modificare codice autodesk, magari non
gradiscono. :-)
tra l'altro dicevano:
"You may not distribute or  publish the source code of this program in any
form."


Ciao Massimo
ma guarda un po' hai fatto prima di me! :-)
bello, ora mi guardo come l'hai risolta tu.
Ciao Giovanni Anzani

Ciao Massimo
abbiamo usato due doluzioni diverse, come avrai visto.
Non avevo pensato ad usare il "change", e' una bella soluzione,
forse rispetto allo "scale to insert point" e' pure una soluzione
piu' elegante... ....senza il forse va!
Accetti consigli, vero?
Quanto al codice potresti agiungere due cose:
1) Puo' essere comodo sfruttare una preselezione.
;------------------------------------------------------------
; GA questo ti permette di recuperare una preselezione di testi
;|GA|; (setq l_imm (ssget "_i" '((0 . "TEXT"))))
;quindi se c'e' gia' una selezione non devi rifarla
;|GA|; (if (not l_imm) (progn
 (princ "Selezionare I TESTI DA SCALARE..\n")
 (setq l_imm (ssget (list (cons 0 "TEXT"))))
;|GA|; ))
;------------------------------------------------------------
2) Puo' essere comodo verificare che il fattore di scala sia
compatibile, se dai 0 o un numero negativo o enter la tua
procedura  va in errore.
;------------------------------------------------------------
  ; GA se usi l'initget puoi controllare i valori ammessi per il tuo getreal
  ; GA  in questo caso (7) deve essere =/ da 0 positivo e non e' ammesso
enter
  ; GA  come risposta
  ;|GA|;(initget 7)
   (SETQ fs (GETREAL "Fattore di scala :"))
;------------------------------------------------------------
..d'altronde io ho avuto piu' tempo per pensarci. :-)
ciao Giovanni Anzani

 ;------------------------------------------------------------
Ok messo
Ma c'è ancora un piccolo particolare che mi piacerebbe risolvere.
Se per caso sbaglio ad inserire il valore della scala oppure avevo sbagliato
la selezione e devo annullare possono sorgere dei problemi se la selezione
era grande (almeno 50 testi). Perché il commando annulla funziona testo per
testo, e se tengo invio premuto rischio di annullare anche qualcosa che
avevo fatto in precedenza.
Come si può risolvere il problema ?
--
Massimo Ghio

 Come si può risolvere il problema ?
Con i marcatori degli undo, guardati a fondo le opzioni del comando undo,
digita "undo" e non "u" al command o vai all'help,
in pratica quando avvii la procedura setti un marcatore di undo,
poi quando finisci puoi fare undo fino al marcatore indipendentemente dalle
"mosse" fatte.... ...te l'ho spiegato maluccio, ma so che puoi farcela!
Ciao GIANZ

Esattamente come serviva a X-file (comunque lo userň anch'io)
Wow, grazie a tutti x l'aiuto.
Ciao da X-file