sistemazione listato per selezione multipla

jim78b

Utente Standard
Professione: PROGETTISTA
Software: Solidworks 2016- autocad mech 2013-2017
Regione: lombardia
#1
ho questo listato per cambiare il colore ai blocchi nidificati mi servirebbe fare che si possa selezionare più di un oggetto grazie e perfavore...


(defun c:blcc () (pl:block-color) (princ))

(defun c:encc () (pl:block-ent-color) (princ))

;;;get from Alaspher http://forum.dwg.ru/showthread.php?t=1036

;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18

(vl-load-com)

(defun pl:block-ent-color (/ adoc blocks color ent lays)

(setq adoc (vla-get-activedocument (vlax-get-acad-object))

lays (vla-get-layers adoc)

color (acad_colordlg 256)

)

(if color

(progn (setvar "errno" 0)

(vla-startundomark adoc)

(while (and (not (vl-catch-all-error-p

(setq ent (vl-catch-all-apply

(function nentsel)

'("\nSelect entity <Exit>:")

)

)

)

)

(/= 52 (getvar "errno"))

)

(if ent

(progn (setq ent (vlax-ename->vla-object (car ent))

lay (vla-item lays (vla-get-layer ent))

)

(if (= (vla-get-lock lay) :vlax-true)

(progn (setq layloc (cons lay layloc))

(vla-put-lock lay :vlax-false)

)

)

(vl-catch-all-apply (function vla-put-color) (list ent color))

(vla-regen adoc acallviewports)

)

(princ "\nNothing selection! Try again.")

)

)

(foreach i layloc (vla-put-lock i :vlax-true))

(vla-endundomark adoc)

)

)

(princ)

)

(defun pl:block-color (/ adoc blocks color ins lays)

(setq adoc (vla-get-activedocument (vlax-get-acad-object))

blocks (vla-get-blocks adoc)

lays (vla-get-layers adoc)

color (acad_colordlg 256)

)

(if color

(progn (setvar "errno" 0)

(vla-startundomark adoc)

(while (and (not (vl-catch-all-error-p

(setq ins (vl-catch-all-apply

(function entsel)

'("\nSelect block <Exit>:")

)

)

)

)

(/= 52 (getvar "errno"))

)

(if ins

(progn (setq ins (vlax-ename->vla-object (car ins)))

(if (= (vla-get-objectname ins) "AcDbBlockReference")

(if (vlax-property-available-p ins 'path)

(princ "\nThis is external reference! Try pick other.")

(progn (_pl:block-color blocks ins color lays)

(vla-regen adoc acallviewports)

)

)

(princ "\nThis isn't block! Try pick other.")

)

)

(princ "\nNothing selection! Try again.")

)

)

(vla-endundomark adoc)

)

)

(princ)

)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)

(vlax-for e (vla-item blocks (vla-get-name ins))

(setq lay (vla-item lays (vla-get-layer e)))

(if (= (vla-get-freeze lay) :vlax-true)

(progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))

)

(if (= (vla-get-lock lay) :vlax-true)

(progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))

)

(vl-catch-all-apply (function vla-put-color) (list e color))

(if (and (= (vla-get-objectname e) "AcDbBlockReference")

(not (vlax-property-available-p e 'path))

)

(_pl:block-color blocks e color lays)

)

(foreach i layfrz (vla-put-freeze i :vlax-true))

(foreach i layloc (vla-put-lock i :vlax-true))

)

)

(progn

(princ "\BLCC - Changes color of the chosen blocks")

(princ "\nENCC - Changes color of the chosen objects (may be element of the block)")

(princ))
 

jim78b

Utente Standard
Professione: PROGETTISTA
Software: Solidworks 2016- autocad mech 2013-2017
Regione: lombardia
#2
poi avrei anche questo che ruota e copia 1 sola volta mi servirebbe che copia infinite volte sino a che interrompo io il comando è possibile? grazie

(defun C:RTC (/ gru)
(setq gru (ssget))

(if gru
(progn
(command "_COPY" gru "" (list 0 0)(list 0 0))
(command "_ROTATE" "_P" "")
(princ "\nBase point e primo punto d'angolo: ")
(command pause "_R")
(command (getvar "LASTPOINT"))
(princ "\nSecondo punto d'angolo: ")
(command pause)
(princ "\nAngolo finale: ")
(command pause)
)
)

(princ)
)
 

Cristallo

Utente Standard
Professione: Leggo e confronto
Software: Lettura critica
Regione: Fuori dalla cerchia
#3
(defun C:RTC (/ gru break)

(setq break nil)
(while (=/ break nil)

(setq gru (ssget))

(if gru
(progn
(command "_COPY" gru "" (list 0 0)(list 0 0))
(command "_ROTATE" "_P" "")
(princ "\nBase point e primo punto d'angolo: ")
(command pause "_R")
(command (getvar "LASTPOINT"))
(princ "\nSecondo punto d'angolo: ")
(command pause)
(princ "\nAngolo finale: ")
(command pause)
)
)

(princ)
)
)
 

jim78b

Utente Standard
Professione: PROGETTISTA
Software: Solidworks 2016- autocad mech 2013-2017
Regione: lombardia
#5
scusami Cristallo non funziona dice:

Command: rtc ; error: no function definition: =/
Command:
 

jim78b

Utente Standard
Professione: PROGETTISTA
Software: Solidworks 2016- autocad mech 2013-2017
Regione: lombardia
#7
abbi pazienza ma mi esce ora:

Command: rtc nil
 

rpor66

Utente Standard
Professione: Programmatore
Software: AutoCad, GstarCAD, CadWorx, Excel, Lisp, VBA
Regione: Sicilia
#8
Codice:
(defun C:RTC (/ gru break)

    (setq break T)
    (while (/= break nil)

        (prompt "\nSeleziona entità: ")
        (setq gru (ssget))

        (if gru
            (progn
                (command "_COPY" gru "" (list 0 0)(list 0 0))
                (command "_ROTATE" "_P" "")
                (princ "\nBase point e primo punto d'angolo: ")
                (command pause "_R")
                (command (getvar "LASTPOINT"))
                (princ "\nSecondo punto d'angolo: ")
                (command pause)
                (princ "\nAngolo finale: ")
                (command pause)
                )
            )

        (princ)
    )
)
(setq break T)
 

jim78b

Utente Standard
Professione: PROGETTISTA
Software: Solidworks 2016- autocad mech 2013-2017
Regione: lombardia
#9
Grazie ora provo :).riesci x favore a sistemare l'altro listato x selezionare piu' oggetti ?te ne sono grato
 

jim78b

Utente Standard
Professione: PROGETTISTA
Software: Solidworks 2016- autocad mech 2013-2017
Regione: lombardia
#10
Ho Provato RTC.LSP ma non è come dico, vorrei fare come il comando copia, che ripete gli oggetti fino a che non interrompo il comando.