Vai al contenuto
arri

Utility free per AutoCAD

Recommended Posts

Testo isometrico

;; Lee Mac

;; ONLY WORKS ON DTEXT

;; Found @ http://www.theswamp.org/index.php?topic=37429.0

(defun c:isotext ( / e i j k)

  (vl-load-com)

;(setq i (/ pi 6.) j -1.)

  (setq i 0 k (/ pi 6.) j -1.)

  ;; © Lee Mac 2011

  (if

	(and

	  (setq e (car (entsel "\nSelect Text: ")))

	  (eq (vla-get-Objectname (setq e (vlax-ename->vla-object e))) "AcDbText")

	  (princ "\nPress [Tab] to Change Projection <Accept>")

	)	  

	(while (= 9 (cadr (grread nil 14 0)))

	 ;(vla-put-rotation	 e i)

	  (vla-put-rotation	 e (* k (1- (* 2 (setq i (rem (+ i (max 0 (setq j (- j)))) 3))))))

	 ;(vla-put-obliqueangle e (setq i (* i (setq j (- j)))))

	  (vla-put-obliqueangle e (* j k))

	)

  )

  (princ)

)

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

oltre alle polilinee, permette di creare velocemente entità coprenti anche selezionando cerchi o ellissi

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07

;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)

;;; Works whatever the current ucs and object OCS

(defun c:ob2wo (/ ent lst nor)

(vl-load-com)

(if (and (setq ent (car (entsel)))

(member (cdr (assoc 0 (entget ent)))

'("CIRCLE" "ELLIPSE" "LWPOLYLINE")

)

(setq lst (ent2ptlst ent))

(setq nor (cdr (assoc 210 (entget ent))))

)

(progn

(vla-StartundoMark

(vla-get-ActiveDocument (vlax-get-acad-object))

)

(makeWipeout lst nor)

(initget "Yes No")

(if

(= (getkword "\nDelete source object? [Yes/No] <No>: ")

"Yes"

)

(entdel ent)

)

(vla-EndundoMark

(vla-get-ActiveDocument (vlax-get-acad-object))

)

)

)

)

;;; ENT2PTLST

;;; Returns the vertices list of the polygon figuring the curve object

;;; Coordinates defined in OCS

(defun ent2ptlst (ent / obj dist n lst p_lst prec)

(vl-load-com)

(if (= (type ent) 'ENAME)

(setq obj (vlax-ename->vla-object ent))

)

(cond

((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))

(setq dist (/ (vlax-curve-getDistAtParam

obj

(vlax-curve-getEndParam obj)

)

50

)

n 0

)

(repeat 50

(setq

lst

(cons

(trans

(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))

0

(vlax-get obj 'Normal)

)

lst

)

)

)

)

(T

(setq p_lst (vl-remove-if-not

'(lambda (x)

(or (= (car x) 10)

(= (car x) 42)

)

)

(entget ent)

)

)

(while p_lst

(setq

lst

(cons

(append (cdr (assoc 10 p_lst))

(list (cdr (assoc 38 (entget ent))))

)

lst

)

)

(if (/= 0 (cdadr p_lst))

(progn

(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))

dist (/ (- (if (cdaddr p_lst)

(vlax-curve-getDistAtPoint

obj

(trans (cdaddr p_lst) ent 0)

)

(vlax-curve-getDistAtParam

obj

(vlax-curve-getEndParam obj)

)

)

(vlax-curve-getDistAtPoint

obj

(trans (cdar p_lst) ent 0)

)

)

prec

)

n 0

)

(repeat (1- prec)

(setq

lst (cons

(trans

(vlax-curve-getPointAtDist

obj

(+ (vlax-curve-getDistAtPoint

obj

(trans (cdar p_lst) ent 0)

)

(* dist (setq n (1+ n)))

)

)

0

ent

)

lst

)

)

)

)

)

(setq p_lst (cddr p_lst))

)

)

)

lst

)

;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object

(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)

(setq dxf10 (list (apply 'min (mapcar 'car pt_lst))

(apply 'min (mapcar 'cadr pt_lst))

(caddar pt_lst)

)

)

(setq

max_dist

(float

(apply 'max

(mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)

)

)

)

(setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))

(setq

dxf14 (mapcar

'(lambda (p)

(mapcar '/

(mapcar '- p cen)

(list max_dist (- max_dist) 1.0)

)

)

pt_lst

)

)

(setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))

(entmake (append (list '(0 . "WIPEOUT")

'(100 . "AcDbEntity")

'(100 . "AcDbWipeout")

'(90 . 0)

(cons 10 (trans dxf10 nor 0))

(cons 11 (trans (list max_dist 0.0 0.0) nor 0))

(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))

'(13 1.0 1.0 0.0)

'(70 . 7)

'(280 . 1)

'(71 . 2)

(cons 91 (length dxf14))

)

(mapcar '(lambda (p) (cons 14 p)) dxf14)

)

)

)


Modificato da arri

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Join Mtext

;; by Joe Burke at Autodesk Forums


;; Join mtext demo.


;; The order of selection determines the result.


;; The first mtext object selected is modified and


;; others are deleted.


(defun c:jmtx ( / e obj lst str)


(vl-load-com)


(while


(and


(setq e (car (entsel "\nSelect mtext: ")))


(setq obj (vlax-ename->vla-object e))


(equal "AcDbMText" (vlax-get obj 'ObjectName))


)


(setq lst (cons obj lst))


)


(setq obj (last lst))


(setq str (vlax-get obj 'TextString))


(foreach x (cdr (reverse lst))


(setq str (strcat str "\\P" (vlax-get x 'TextString)))


(vla-delete x)


)


(vlax-put obj 'TextString str)


(princ)


)

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

This routine will let you easily find blocks in your drawing. It does this by drawing lines from the insertion point of the blocks to a user specified point.

Here’s how:

OU <enter> to start

Notice the options in the command line:

select a Block – (default) Select a block from the drawing area

Choose from list – select a block by its name from a list

Origin – Specify a point on screen that all of the lines will point to

After choosing one of these options, you should see lines from all of the instances of the specified block (from their insertion points) to the “origin”

This routine requires that you save 2 files: 1) the .lsp file (LISP) and 2) the .dcl file which is the dialog box for the routine.

Save the below code as OU.dcl

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Copy2Lay

The object or objects selected in the modelspace or in the paperspace of one of the layouts will be copied over to all or specified (with a name mask) layouts of the current DWG drawing, to identical coordinates. So you can quickly "clone" e.g. a title, legend, logo or a full viewport.

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

elimina frecce quote

autore: Terminator

(defun C:ELIMBF (/ grudim index)

(setq grudim (ssget '((0 . "DIMENSION")))

index 0

)

(repeat (sslength grudim)

(vla-put-arrowhead1block (vlax-ename->vla-object (ssname grudim index)) "_none")

(vla-put-arrowhead2block (vlax-ename->vla-object (ssname grudim index)) "_none")

(setq index (1+ index))

)

(princ)

)


Modificato da arri

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Convertire Testi in Multileader

(defun c:am (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth)

(vl-load-com)

(defun rjp-getbbwdth (obj / out ll ur)

(vla-getboundingbox obj 'll 'ur)

(setq out (mapcar 'vlax-safearray->list (list ll ur)))

(distance (car out) (list (caadr out) (cadar out)))

)

(if (setq ss (ssget '((0 . "*TEXT"))))

(progn (setq txt (apply

'strcat

(mapcar

'cdr

(vl-sort

(mapcar '(lambda (x)

(cons (vlax-get x 'insertionpoint)

(strcat (vlax-get x 'textstring) " ")

)

)

(setq

ss (mapcar

'vlax-ename->vla-object

(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

)

)

)

(function (lambda (y1 y2) (< (cadr (car y2)) (cadr (car y1))))

)

)

)

)

w (car (vl-sort (mapcar 'rjp-getbbwdth ss) '>))

txt (apply 'strcat

(mapcar 'chr (reverse (cdr (reverse (vl-string->list txt)))))

)

)

(mapcar 'vla-delete ss)

)

)

(if (and (setq pt1 (getpoint "\nSpecify leader arrowhead location: "))

(setq pt2 (getpoint pt1 "\nSpecify landing location: "))

)

(progn (command "._MLEADER" pt1 pt2 "")

(setq newleader (vlax-ename->vla-object (entlast)))

(vla-put-textstring newleader txt)

(vla-put-textwidth newleader w)

)

)

(princ)

)


Modificato da arri

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

ViewPort Lock & Unlock

; By Lee-Mac found at the Augi forums


;; Lock Selected Viewport


(vl-load-com)


(defun c:vpl nil


(if (SSVPLock (ssget "_+.:E:S:L" '((0 . "VIEWPORT"))) :vlax-true)


(princ "\n--> Viewport Locked.")


)


(princ)


)


;; Unlock Selected Viewport


(defun c:vpu nil


(if (SSVPLock (ssget "_+.:E:S:L" '((0 . "VIEWPORT"))) :vlax-false)


(princ "\n--> Viewport Unlocked.")


)


(princ)


)


;; Lock All Viewports


(defun c:vpla nil


(SSVPLock (ssget "_X" '((0 . "VIEWPORT"))) :vlax-true)


(princ "\n--> All Viewports Locked.")


(princ)


)


;; Unlock All Viewports


(defun c:vpua nil ;; changed "VPLU" to "VPUA" to be consistant with the above function


(SSVPLock (ssget "_X" '((0 . "VIEWPORT"))) :vlax-false)


(princ "\n--> All Viewports UnLocked.")


(princ)


)


(defun SSVPLock ( ss lock / i )


(if ss


(repeat (setq i (sslength ss))


(vla-put-displaylocked (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lock) t


)


)


)

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Trovare il centroide di una regione

(defun GetCentroid ()

(vl-load-com)

(setq anEnt (entsel "\nSelect A Region: "))

(if anEnt

	(progn

	  (setq anObj (vlax-ename->vla-object (car anEnt)))

	  (princ (strcat "\nObject Name: " (setq objName (vla-Get-ObjectName

anObj))))

	  (if (equal objName "AcDbRegion")

		(progn

		  (setq vCentroid (vla-Get-Centroid anObj))

		  (setq strCentroidProp (vl-princ-to-string (setq CentroidLst

(vlax-safearray->list (vlax-variant-value vCentroid)))))

		  (if (< (length CentroidLst) 3)

		   (setq CentroidLst (append CentroidLst (list 0.0)))

		  )

		  (princ (strcat "\nRegion Centroid: " strCentroidProp))

		  (setvar "PDMODE" 3)

		  (setq *MS* (vla-Get-ModelSpace (setq acadDoc

(vla-Get-ActiveDocument (setq acadApp (vlax-get-acad-object))))))

		  (setq ptObj (vla-AddPoint *MS* (vlax-3d-Point CentroidLst)))

		  (vla-Put-Color ptObj acYellow)

		)

		(princ "\nRegion was not selected !")

	  )

	)

)

(princ)

)


(princ "\nGetCentroid loaded, type (GetCentroid) to run.")

(princ)


Modificato da arri

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

creare Layout numerati

(defun c:mkl (/ cnt lnum)

  (setvar 'cmdecho 0)

  (while

	(progn

	  (initget 7)

	  (setq cnt  1000

   lnum (getint "\nHow Many Layouts: ")

	  )

	  (if (<= lnum (length (layoutlist)))

(princ "\nNumber is below/equal current number of Layout:")

nil

	  )

	)

  )

  (foreach itm (layoutlist)

	(command "layout"

	"_rename"

	itm

	(strcat (itoa (setq cnt (1+ cnt))))

	)

  )

  (repeat (- lnum (length (layoutlist)))

	(command "layout" "_new" (strcat (itoa (setq cnt (1+ cnt)))))

  )

  (princ)

)


(defun c:copyl (/ cnm lnum)

  (initget 7)

  (setq cnm  (last (layoutlist))

lnum (getint "\nNumber of Layouts to Add: ")

  )

  (repeat lnum

	(command "_layout"

	"_copy"

	cnm

	(setq cnm (itoa (1+ (atoi cnm))))

	)

  )

)

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Listing Defined AutoLISP Variables and Functions

(defun c:LISPDumpFile ( / afList nSyms nFuncs nCmds nVars

										lstSyms lstFuncs lstCmds lstVars

										item fp)

	(setq afList (atoms-family 1))

	(setq nSyms 0 nFuncs 0 nCmds 0 nVars 0

			 lstSyms nil lstFuncs nil lstCmds nil lstVars nil)

	(foreach item aflist

		(progn

		   (cond

			   ((= (type (eval (read item))) 'SYM)

					(progn

						(setq nSyms (1+ nSyms))

						(if (/= lstSyms nil)

							(setq lstSyms (append lstSyms (list item)))

							(setq lstSyms (list item))

						)

					)

			   )

			   ((and (= (type (eval (read item))) 'SUBR) (/= (substr (strcase item) 1 2) "C:"))

					 (progn

						  (setq nFuncs (1+ nFuncs))

						  (if (/= lstFuncs nil)

							  (setq lstFuncs (append lstFuncs (list item)))

							  (setq lstFuncs (list item))

						  )				

					 )

			   )

			   ((and (= (type (eval (read item))) 'SUBR) (= (substr (strcase item) 1 2) "C:"))

					 (progn

						  (if (/= (strcase item) (strcase "c:LISPDumpFile"))

							  (progn

								  (setq nCmds (1+ nCmds))

								  (if (/= lstCmds nil)

									  (setq lstCmds (append lstCmds (list item)))

									  (setq lstCmds (list item))

								  )

							  )

						  )

					 )

			   )

			   ((or (= (type (eval (read item))) 'REAL)

					(= (type (eval (read item))) 'INT)

					(= (type (eval (read item))) 'LIST)

					(= (type (eval (read item))) 'PICKSET)

					(= (type (eval (read item))) 'ENAME)

					(= (type (eval (read item))) 'VLA-OBJECT)

					(= (type (eval (read item))) 'FILE)

					(= (type (eval (read item))) 'VARIANT)

					(= (type (eval (read item))) 'STR))

						(progn

							(setq nVars (1+ nVars))

							(if (/= lstVars nil)

								(setq lstVars (append lstVars (list item)))

								(setq lstVars (list item))

							)

						)

			   )

		   )

		)

	)

	;; Output details about defined Symbols and Functions

	(prompt (strcat "\nAutoLISP Symbols and Functions count: "

					"\nSymbols - " (itoa nSyms)

					"\nFunctions - " (itoa nFuncs)

					"\nGlobal Variables - " (itoa nVars)

					"\nCommands - " (itoa nCmds))

	)

	(setq fp (open "c:\\LspDumpFile.log" "w"))

	(write-line "Symbols" fp)

	(setq lstSyms (acad_strlsort lstSyms))

	(foreach item lstSyms

		(write-line item fp)

	)

	(write-line "" fp)

	(write-line "Functions" fp)

	(setq lstFuncs (acad_strlsort lstFuncs))

	(foreach item lstFuncs

		(write-line item fp)

	)

	(write-line "" fp)

	(write-line "Global Variables" fp)

	(setq lstVars (acad_strlsort lstVars))

	(foreach item lstVars

		(write-line item fp)

	)

	(write-line "" fp)

	(write-line "Commands" fp)

	(setq lstCmds (acad_strlsort lstCmds))

	(foreach item lstCmds

		(write-line item fp)

	)

	(close fp)

  (princ)

)

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

- rinominare blocchi selezionati (anche anonimi *X) -

autore G.P.

;;; file: RB.lsp ;;;

;;; data: 22/10/2008 ;;;

;;; note: rinomina il blocco selezionato ;;;

;;; ;;;

;;; aggiornamento: (Versione 2) - 01/04/2009 ;;;

;;; - default sulla casella OK ;;;

;;; - controllo esistenza nome blocco ;;;

;;; ;;;

;;; aggiornamento: (Versione 3) - 02/04/2009 ;;;

;;; - allargata casella editazione nome blocco ;;;

;;; ;;;

;;; aggiornamento: (Versione 4) - 28/10/2012 ;;;

;;; - rinomina blocchi dinamici e blocchi anonimi ;;;

;;; - creazione di blocchi anonimi ;;;

;;; - inglobamento DCL nel lisp ;;;

;;; ;;;

;;; autore: Gian Paolo Cattaneo ;;;



(defun c:RB (/ :bb old new dcl_id)


(prompt "\n ") (prompt "\n ") (prompt "\n ")

(if

(while (not :bb)

(setvar 'errno 0)

(setq :bb (car (entsel "\nSelezionare il Blocco da Rinominare")))

(if (= 7 (getvar 'errno))

(alert "Nessun oggetto selezionato")

)

(if (= 'ename (type :bb))

(if (null (wcmatch (cdr (assoc 0 (entget :bb))) "INSERT"))

(progn

(alert "L'oggetto non è un Blocco")

(setq :bb nil)

)

(progn

(setq old (vla-get-effectivename (vlax-ename->vla-object :bb)))

)

)

)

)

(progn

(RB_dcl)

(while

(and

(/= (strcase old) (strcase new))

(tblsearch "BLOCK" new)

)

(alert "Un blocco con questo nome esiste già")

(RB_dcl)

)

(vla-put-Name

(vla-item

(vla-get-blocks

(vla-get-activedocument

(vlax-get-acad-object)

)

)

old

)

new

)

)

)

(prompt "\n ") (prompt "\n ") (prompt "\n ")

(princ)

)



(defun RB_dcl ( / DCLname)

(setq DCLname (strcat (getvar 'localrootprefix) "RB_V4.dcl"))

(if (not (findfile DCLname)) (crea_dcl_RB))

(if (= POSIZ_DCL_RB nil) (setq POSIZ_DCL_RB (list -1 -1)))

(setq dcl_id (load_dialog DCLname))

(if (not (new_dialog "RB4" dcl_id "" POSIZ_DCL_RB)) (exit))

(setq new old)

(set_tile "new" new)

(action_tile "new" "(setq new $value)")

(start_dialog)

(unload_dialog dcl_id)

)



(defun crea_dcl_RB (/ fn f)

(setq fn DCLname)

(setq f (open fn "w"))

(write-line "RB4:dialog {" f)

(write-line "label = \"RB - Rinomina Blocco (Vers. 4)\";" f)

(write-line "" f)

(write-line " initial_focus=\"new\";" f)

(write-line "" f)

(write-line " : spacer {}" f)

(write-line " : spacer {}" f)

(write-line " : spacer {}" f)

(write-line "" f)

(write-line " : text {" f)

(write-line " label = \"Nuovo Nome Blocco:\";" f)

(write-line " alignment = centered;" f)

(write-line " } " f)

(write-line "" f)

(write-line " : text {" f)

(write-line " label = \"(digitare: *U per creare un Blocco Anonimo)\";" f)

(write-line " alignment = centered;" f)

(write-line " } " f)

(write-line "" f)

(write-line " : spacer {}" f)

(write-line "" f)

(write-line " : edit_box {" f)

(write-line " key=\"new\";" f)

(write-line " allow_accept=true;" f)

(write-line " }" f)

(write-line "" f)

(write-line " : spacer {}" f)

(write-line " : spacer {}" f)

(write-line " : spacer {}" f)

(write-line "" f)

(write-line " ok_only;" f)

(write-line "" f)

(write-line " : spacer {}" f)

(write-line " : spacer {}" f)

(write-line " : spacer {}" f)

(write-line "" f)

(write-line " : text { " f)

(write-line " label = \"Copyright © 2012 - Gian Paolo Cattaneo\";" f)

(write-line " alignment = centered;" f)

(write-line " }" f)

(write-line "" f)

(write-line "}" f)

(close f)

(load_dialog fn)

)


;******************************************************************************


(vl-load-com)


(prompt "\n ") (prompt "\n ") (prompt "\n ")

(princ "\nRinominare un Blocco (V.4) - by Gian Paolo Cattaneo")

(princ "\nDigitare RB per lanciare il lisp")

(princ)



Modificato da arri

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Curve matematiche parametriche in AutoCAD

CADStudio 2DPlot is an AutoLISP utility for AutoCAD - it generates parametric 2D curves (polylines) from mathematic expressions (functions, equations). You can use 2DPlot for educational purposes (math visualization) but also in the design area - e.g. for creation of attractive architectural features, interior design, product design, for DTP (guilloches), for art design, etc. See also 3DPlot for 3D surfaces.

The core application contains functionality required to generate 2D curves from results of math expressions of the type [X,Y] = f(U). You need to specify a user defined function for "f", plus a definition interval of U values (starting value, end value, step size).

After loading 2DPlot you can generate the 2D graphical results simply by calling the LISP function:

(2DPlot functionName startU endU stepU)

e.g. (see case 1 - Sinusoid; 100 steps):

(2DPlot fXYt1 (* -2 pi) (* 2 pi) (/ (* 4 pi) 100))

The 2DPlot utility also contains several predefined functions (equations of 2D curves) to demo its features. Here is the list of them, including previews of their results:


Modificato da arri

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Draw normals of 3DFaces

With the free AutoLISP utility CADstudio Normals you can draw normals of 3D faces in your DWG drawing.

Download the Normals.vlx from www.cadstudio.cz/download, load it with APPLOAD and start the NORMALS command. Now select all 3DFaces to analyze (you may want to EXPLODE your 3D mesh object first, e.g. objects from 3DPLOT). You can choose to draw Normals or to recolor the individual Faces.

The Normals option draws vectors going from the face center "outwards", from its "front" side. Any normals going away from you indicate a backface (reversed). The normals are created in the layer "Normals", they have the same length (1/20 of the current viewport size) and they are either red or blue. Red normals go towards the current view direction (camera), the blue ones face away. Please note that the colors depend on the current view direction. Rerun the command if you change the view rotation.

Condividi questo messaggio


Link al messaggio
Condividi su altri siti

Crea un account o accedi per commentare

Devi essere un utente per poter lasciare un commento

Crea un account

Registrati per un nuovo account nella nostra comunità. è facile!

Registra un nuovo account

Accedi

Hai già un account? Accedi qui.

Accedi ora

  • Navigazione recente   0 utenti

    Non ci sono utenti registrati da visualizzare in questa pagina.

×