Pipe Maker: Offset Lines, Arcs, Splines, Polylines Both Sides and convert original axes to center line


;;; Pipe Maker: Offset Lines, Arcs, Splines, Plines Both Sides and convert original axes to center line
;;; Based on Ranjit.Singh routine
;;; Modified by Igal Averbuh 2018 (added convert axes to center line)
;;; Saved from: http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/offset-both-sides-erase-originals/m-p/6598353#U6598353

;; Load Linetypes - Lee Mac
;; Attempts to load a list of linetypes from any .lin files found in the support path.
;; Excludes known metric & imperial definition files based on the value of MEASUREMENT
;; lts - [lst] List of linetypes to load
;; rdf - [bol] If T, linetypes will be redefined from file if already loaded
;; Returns: [bol] T if all linetypes are loaded successfully, else nil

(defun LM:loadlinetypes ( lts rdf / lst ltc rtn val var )
(if (zerop (getvar 'measurement))
(setq lst (mapcar 'strcase '("acadiso.lin" "iso.lin"))) ;; Known metric .lin files
(setq lst (mapcar 'strcase '("acad.lin" "default.lin"))) ;; Known imperial .lin files
)
(setq ltc (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object)))
var '(cmdecho expert)
val (mapcar 'getvar var)
lst (vl-remove-if '(lambda ( x ) (member (strcase x) lst))
(apply 'append
(mapcar '(lambda ( dir ) (vl-directory-files dir "*.lin" 1))
(vl-remove "" (LM:str->lst (getenv "ACAD") ";"))
)
)
)
)
(mapcar 'setvar var '(0 5))
(setq rtn
(apply 'and
(mapcar
'(lambda ( typ )
(cond
( (not (tblsearch "ltype" typ))
(vl-some
'(lambda ( lin )
(vl-catch-all-apply 'vla-load (list ltc typ lin))
(tblsearch "ltype" typ)
)
lst
)
)
( rdf
(vl-some
'(lambda ( lin )
(and (LM:ltdefined-p typ lin)
(vl-cmdf "_.-linetype" "_L" typ lin "")
(tblsearch "ltype" typ)
)
)
lst
)
)
( t )
)
)
lts
)
)
)
(mapcar 'setvar var val)
rtn
)

;; Linetype Defined-p - Lee Mac
;; Returns T if the linetype is defined in the specified .lin file
;; ltp - [str] Linetype name
;; lin - [str] Filename of linetype definition file (.lin)

(defun LM:ltdefined-p ( ltp lin / str rtn )
(if
(and
(setq lin (findfile lin))
(setq lin (open lin "r"))
)
(progn
(setq ltp (strcat "`*" (strcase ltp) "`,*"))
(while
(and (setq str (read-line lin))
(not (setq rtn (wcmatch (strcase str) ltp)))
)
)
(close lin)
rtn
)
)
)

;; String to List - Lee Mac
;; Separates a string using a given delimiter
;; str - [str] String to process
;; del - [str] Delimiter by which to separate the string
;; Returns: [lst] List of strings

(defun LM:str->lst ( str del / pos )
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del))
(list str)
)
)

(vl-load-com) (princ)

(LM:loadlinetypes '("hidden" "center" "phantom") nil)

;; Set linetype of selected polyline to continuous

(defun c:lts ( / *error* idx sel wid )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))

(setq sel (ssget "P" (list '(0 . "LWPOLYLINE"))))

(command "_.change" sel "" "_P" "_LT" "center" "")
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)

(defun c:pm1 ( / *error* of undo doc ss ) ;Ekv Both
(defun *error* ( msg )
(and undo (vla-EndUndomark doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ))
(if (and (ssget '((0 . "ARC,CIRCLE,ELLIPSE,*LINE")))
(setq of (getdist "\nSpecify Offset Distance: ")))
(progn
(setq undo (not (vla-StartUndomark (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))))
(vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
(mapcar (function (lambda (o) (vl-catch-all-apply (function vla-offset) (list obj o))))
(list of (- of))))
(setq undo (vla-EndUndoMark doc))))
(princ)
)

(defun c:pm ( / )

(c:pm1)
(c:lts)
)
(c:pm)

Advertisements

Modified Angelo Stocco ViewPort Creator – CFL (added option for multiple rectangular viewports)


;;; --------------------------------------------------------------------------------- ;;;
;;; Create Layout Windows & Layout Manager ;;;
;;; Deeply modified by Igal Averbuh 2018 (added option for multiple rectangular viewports)
;;; -------------------------------------------------- ------------------------ ;;;
;;; Requires "ai_utils.lsp" ;;;
;;; ;;;
;;; It derives from the similar program: "Mishaeli ViewPort Creator" by Isak Mishaeli ;;;
;;; ;;;
;;; In the various updates I have used functions found in the forums, some ;;;
;;; used in full, others with appropriate modifications. ;;;
;;; A dutiful delivery to those who have simplified my work: ;;;
;;; Bill Kramer, Tee Square Graphics, Gilles Chanteau, Marc'Antonio Alessi, ;;;
;;; Lee McDonnell, kojacek, Tharwat, Piercey-Jason, Richard Willis, etc. ;;;
;;; The function headings contain the names of the respective authors. ;;;
;;; -------------------------------------------------------------------------- ;;;
;;; Commands: ;;;
;;; ;;;
;;; CreaFinLay: Create Layout Windows (graphic dialog - DCL) ;;;
;;; CFL: Abbreviation of CreaFinLay ;;;
;;; ;;;
;;; -GFL: Management of Layot Windows (command line options) ;;;
;;; - Window Options: Lock, sbLock, Rotate, LockAll ;;;
;;; - Windows Layer Options: Congelayers, Isolayers, Scongelayers ;;;
;;; -? Guide ;;;
;;; FLINFO: Information Layout window and restore annotation scale ;;;
;;; - when the pointer passes over the frame, it shows a scale ;;;;;
;;; unit used; ;;;
;;; - clicking on it with the left mouse button, enter the annotation ;;;
;;; of the ladder and opens the editor to complete the description ;;;
;;; ;;;
;;; -------------------------------------------------- ------------------------ ;;;
;;; Angelo Stocco - April 2016 ;;;
;;; -------------------------------------------------- ------------------------ ;;;
;;; 2007 October - 1st edition AS ;;;
;;; Revisions: ;;;
;;; 2016
;;; "Dirty" translated to English by Igal Averbuh 2018 ;;;
;;; because It's better than nothing ;;;
;;; ;;;
;;; --------------------------------------------------------------------------------- ;;;
(defun c:CFL (/) (c:CreaFinLay))
(defun c:CreaFinLay (/ Convert Dcl_Id% result Ent Entname
EntNamePLay EntNamePModel FattZoom fileread Index
IndexC L_LAY L_SCA Lay LayAnnFIN LayDim
LayFin Li_DCA aline ListaV ListaVX ListaVY
minX minY Appl maxX maxY n
nrVertici oldlayer oldTxtStyle p pC Ptmin
Ptmax PtCen Sca ScXP ScXPDCL ssvp
StyDim StyDTxt StyTxt TE ValSca WriteScala
AppNum Wc0 Pt2 PtRagMag Larg_SC PC_SC
Wc1 Wc2 EntVP $a $b $c
EntNamePLayVP Lst-Serie oldsnap CreDimScala Alt_SC
DataOggi OraOggi NListaV Wc1M Wc2M pcName
pcCode filename ListaDS dimstyle_names DS_nlst
StQuo RigaCommento0 RigaCommento1 UnitXD
PrefStyDim NumVP globalList globalListPick RES
BT Dimstyle NewDim OldStyDim StyDimARCHI StyDimMECCA
dimstyle_names StyDimSTAND)

(setq olderr *error*
*error* attrerrCfl
)

;;; --------------------------------------------------------------------------------- ;;;
;;; from Autodesk FIND.LSP
;;; Check to see if AI_UTILS is loaded, If not, try to find it, and then try to load it.
;;; If it can't be found or it can't be loaded, then abort the loading of this file
;;; immediately, preserving the (autoload) stub function.
;;; --------------------------------------------------------------------------------- ;;;
(cond
((and ai_dcl (listp ai_dcl))) ; it's already loaded.
((not (findfile "ai_utils.lsp")) ; find it
(ai_abort "CreaFinLay" "file AI_UTILS.LSP. not found\n Check the support folder."))

((eq "failed" (load "ai_utils" "failed")) ; load it
(ai_abort "CreaFinLay" "Unable to load the file AI_UTILS.LSP"))
)

(if (not (ai_acadapp)) ; defined in AI_UTILS.LSP
(ai_abort "CreaFinLay" nil) ; a Nil supresses
) ; ai_abort's alert box dialog.

;;; --------------------------------------------------------------------------------- ;;;
(setq Appl "CreaFinLay")
(setq RigaCommento0 "CreaFinLay v6.0")
(setq RigaCommento1 "AS - 15.04.2016")

; Salva le variabili di sistema
(arcvar (list "cmdecho" "clayer" "osmode" "regenmode" ))

(setvar "cmdecho" 0)

; plinetype 2: crea e converte in polilinee ottimizzate "LWPOLYLINE"
(setvar "plinetype" 2)

(setq OldStyDim (getvar "Dimstyle"))
(setq oldlayer (getvar "clayer"))
(setq oldTxtStyle (getvar "textstyle"))
(setq oldsnap (getvar "osmode" ))
(command "_.undo" "_begin")
(SETQ VerCAD (substr (GETVAR "ACADVER") 1 4))

(cond
((= Lay_nlst nil)
(setq Lay_nlst (vl-position (getvar "CTAB") (mapcar 'vla-get-Name (getLays))))
)
((/= Lay_nlst (vl-position (getvar "CTAB") (mapcar 'vla-get-Name (getLays))) nil)
(setq Lay_nlst (vl-position (getvar "CTAB") (mapcar 'vla-get-Name (getLays))))
)
)
(if (/= "CTAB" "Model")
(setvar "CTAB" "Model")
)
(CreaLayStyTXT)

;;; --------------------------------------------------------------------------------- ;;;
;;;Initialation_Code
(defun DCL_inizio_gestione(/)
(LogoCFL "vectors")
(ListaLay)
(ListaDimStili)
(LeggiFileScale)
(m_cm_mm)
(ScalaFinLay)
(FormaFin)
(mode_tile "$LAY" 2) ; attiva Focus selezione layout
(set_tile "$CSD" "0")
(setq CreDimScala "0")
(mode_tile "$rc0" 1)
(set_tile "$rc0" RigaCommento0)
(mode_tile "$rc1" 1)
(set_tile "$rc1" RigaCommento1)
(set_tile "$WS" "0")
(setq WriteScala "1")
(set_tile "$ScXP" (strcat "Zoom "ScXP))
(mode_tile "$DST" 1)
(princ)
);End of Initial Function

;;;Start Set function
(defun DCL_imposta_dati(/)
(action_tile "$M" "(setq Convert 1000.0 Unit$ \"m\")(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$CM" "(setq Convert 10.0 Unit$ \"cm\")(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$MM" "(setq Convert 1.0 Unit$ \"mm\")(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$LSCA" "(setq Sca_nlst (atoi $value))(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$CSD" "(StiliDIM)(ListaDimStili)(setq CreDimScala (get_tile \"$CSD\"))(if (= CreDimScala \"1\" )(congela)(scongela))")
(action_tile "$WS" "(setq WriteScala (get_tile \"$WS\"))")
(action_tile "$RET" "(setq Forma$ \"RET\")")
(action_tile "$CER" "(setq Forma$ \"CER\")")
(action_tile "$ELI" "(setq Forma$ \"ELI\")")
(action_tile "$POL" "(setq Forma$ \"POL\")")
(action_tile "$LAY" "(setq Lay_nlst (atoi $value))")
(action_tile "$DST" "(setq DS_nlst (atoi $value))")
(action_tile "$EdSca" "(EditaScale)")
(princ)
);End of Set function

;;;Start Get function
(defun DCL_rileva_dati(/)
(setq Lay_nlst (atoi (get_tile "$LAY")))
(setq Lay (nth Lay_nlst L_LAY))
(setq DS_nlst (atoi (get_tile "$DST")))
(setq StQuo (nth DS_nlst ListaDS))
(ScalaFinLay)
(m_cm_mm)
(FormaFin)
(princ)
);End of Get function

(create_dcl "viewport-creator5.dcl")
(if (setq Dcl_Id% (load_dialog (strcat (getvar "roamablerootprefix")"viewport-creator5.dcl")))
(if (not (new_dialog "CreaFinLayout" Dcl_Id%)) (exit)
(progn
(setq result nil)
(DCL_inizio_gestione)
(DCL_imposta_dati)
(action_tile "help" "(InfoCreaFinLay))")
(action_tile "cancel" "(done_dialog)(exit)")
(action_tile "accept" "(DCL_rileva_dati)(done_dialog)(setq result T)")
(start_dialog)
(unload_dialog Dcl_Id%)
result
)
)
)

(if (/= CreDimScala "1")
(progn
(cond
((= Forma$ "RET")(igalvp)(XDAdd))
((= Forma$ "CER")(VportCER)(XDAdd))
((= Forma$ "ELI")(VportELI)(XDAdd))
((= Forma$ "POL")(VportPOL)(XDAdd))
)
(if (= WriteScala "1")(ScriveScala_TM))
);progn
);if

(cond
((= CreDimScala "1")
(command "_.-dimstyle" "_restore" StQuo)
(CreaStyDim)
(_SetDimStyleCurrent NewDim)
; la creazione delle quote imposta anche l'altezza dei testi a 2.5 mm
(setvar "textsize" (/ 2.5 (distof FattZoom 2)))
)
)

(command "_.undo" "_end")

; Riporta le variabili di sistema al valore iniziale
(resvar)
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; SAVARS.LSP Generic routines for saving selected system variables before executing
;;; external applications, and restoring them afterward.
;;; Tee Square Graphics - http://www.turvill.com/t2/
;;; --------------------------------------------------------------------------------- ;;;
;; (arcvar...) creates a global list from the list contained
;; in the calling program consisting of the listed System
;; Variables and their current values.
;;
;; (revars) restores the System Variables that may have been
;; modified by the calling program to the values saved by
;; the (savars...) function
;;
;;example usage (arcvar (list "cmdecho" "plinewid"))

(defun arcvar (va)
(setq varsis '())
(repeat (length va)
(setq
varsis (append varsis (list (cons (car va) (getvar (car va)))))
)
(setq va (cdr va))
)
)
;;
(defun resvar ()
(repeat (length varsis)
(setvar (caar varsis) (cdar varsis))
(setq varsis (cdr varsis))
)
)

;;; --------------------------------------------------------------------------------- ;;;
;;;; Detentore errori sistema
;;; --------------------------------------------------------------------------------- ;;;

;;; Internal error handler
;;;
(defun attrerrCfl (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(if (/= s "Funzione annullata")
(princ)
(progn
(princ (strcat "\n !! programma interrotto !! : "))
(command "_.undo" "_end")
(command "_.undo" "")
)
)
(resvar) ; restore saved modes
(setq *error* olderr) ; restore old *error* handler
(princ)
)
;;;

;;; ===================== load-time error checking ============================
;;;
(defun ai_abort (app msg)
(defun *error* (s)
(if old_error (setq *error* old_error))
(princ)
);defun

(if msg
(alert (acet-str-format " Errore dell'applicazione: %1 \n\n %2 \n" app msg))
);alert
(exit)
);defun_ai_abort

;;; --------------------------------------------------------------------------------- ;;;
;;; kojacek - forum.cad.pl
;;; Numero convertito in stringa in unitא correnti e accuratezza
;;; soppressione zero finali
;;; uso (CAL_Rtos 100.00111110001888888 T) -> "100.001111100019"
;;; (CAL_Rtos 100.00111110001888888 nil) -> "100.0011"
;;; --------------------------------------------------------------------------------- ;;;
(defun CAL_RtoS (Val Mode / DMZ res)
(setq DMZ (getvar "DIMZIN"))
(setvar "DIMZIN"
(if (member (getvar "LUNITS")(list 4 5)) 0 8)
)
(setq res
(rtos
Val (getvar "LUNITS")
(if Mode 12 (getvar "LUPREC"))
)
)
(setvar "DIMZIN" DMZ)
res
)

;;; --------------------------------------------------------------------------------- ;;;
;;; CreaFinLAY predisposizione Layer supporto e Stile_Txt
;;; --------------------------------------------------------------------------------- ;;;
(defun CreaLayStyTXT (/)
(setq LayFIN (cdr (assoc 2(tblsearch "layer" "0-ViewPort"))) ;; layer Finestre
LayAnnFIN (cdr (assoc 2(tblsearch "layer" "0-Annotation Scale"))) ;; layer TestoAnnotazioneScala
StyTxt (cdr (assoc 2(tblsearch "style" "cfFinlay"))) ;; stile testo Finestre
)
(if (not LayFIN)
(progn
(setq LayFIN "0-ViewPort")
(Crea_Layer LayFIN "" "Continuous" "-3" "1" "0")
)
)
(if (not LayAnnFIN)
(progn
(setq LayAnnFIN "0-Annotation Scale")
(Crea_Layer LayAnnFIN "" "Continuous" "-3" "1" "1")
)
)
(if (not StyTxt)
(progn
(setq StyTxt "cfFinlay")
(if (= nil (findfile (strcat (getenv "Windir") "\\fonts\\arial.ttf")))
(Crea_StileTXT StyTxt "isocp.shx" 0)
(Crea_StileTXT StyTxt "arial.ttf" 0)
)
)
)
(setq LayDim (cdr (assoc 2(tblsearch "layer" "Dim"))))
(if (not LayDim)
(progn
(command "_.-layer" "_make" "Dim" "_color" "7" "" "")
(setq LayDim "Dim")
)
)

(setq StyDTxt (cdr (assoc 2(tblsearch "style" "Dim"))))
(if (not StyDTxt)
(progn
(setq StyDTxt "Dim")
(if (not (findfile (strcat (getenv "Windir") "\\fonts\\arial.ttf")))
(Crea_StileTXT StyDTxt "isocp.shx" 0)
(Crea_StileTXT StyDTxt "arial.ttf" 0)
)
)
)

) ;_ fine CreaLayStyTXT

;;; --------------------------------------------------------------------------------- ;;;
;;; crea layer
;;; -Plot sarא 1 or 0 (Plot or no Plot)
;;; -spessore puע essere .05 per .05 o -3 per default
;;; (Crea_Layer "Nome" "Descrizione" "continuous" "spessore" "colore" "plot")
;;; --------------------------------------------------------------------------------- ;;;
(defun Crea_Layer (Layer Descrizione TipoDiLinea SpessoreLin Colore Plot / VLA-Obj)
;;; aggiunge il tipolinea se non giא presente
(if (not (tblsearch "LTYPE" TipoDiLinea))
(command "_.-linetype" "_L" TipoDiLinea "acadiso.lin" "")
)
;;; Lista per EntMake
(entmake
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 70 0)
(cons 2 Layer)
(cons 62 (atoi Colore))
(cons 6 TipoDiLinea)
(cons 370 (atoi SpessoreLin))
(cons 290 (atoi Plot))
)
)
;; Crea layer descrizione
(if (>= (atof (getvar "acadver")) 16.1)
(progn
(setq Layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
(setq VLA-Obj (vla-Add Layers Layer))
(vla-Put-Description VLA-Obj Descrizione)
(vlax-release-object VLA-Obj)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Crea StileTesto
;;; (Crea_StileTXT "cfFinlay" "isocpeur.ttf" 0)
;;; --------------------------------------------------------------------------------- ;;;
(defun Crea_StileTXT (StileNome FontNome TxtAlt /)
(entmake
(list
(cons 0 "STYLE")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbTextStyleTableRecord")
(cons 2 StileNome) ;; Style Name
(cons 70 0)
(cons 40 TxtAlt) ;; Fixed text height
(cons 41 1.0) ;; Width Factor
(cons 50 0.0) ;; Oblique angle
(cons 71 0)
(cons 42 TxtAlt) ;; Last height used
(cons 3 FontNome) ;; Primary font name
(cons 4 "") ;; Big font name
)
)
)

;;; --------------------------------------------------------------------------------- ;;;
;; Piercey, Jason - Creating dimstyles with VL -
;; Arguments: Type, description:
;; Name: string, dimstyle name
;; VarLst: list, list of lists '((VarName VarValue)) or nil
;; Return: VlaObject of the dimstyle
;;; --------------------------------------------------------------------------------- ;;;
(defun DimSetup (Name VarLst / Obj)
(cond
(VarLst
(mapcar '(lambda (x)
(vla-setvariable *doc* (car x) (cadr x))
)
VarLst
)
(setq Obj (vla-add *dims* Name))
(vla-copyfrom Obj *doc*)
(vla-put-activedimstyle *doc* Obj)
)
(T (setq Obj (vla-add *dims* Name)))
)
Obj
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Disattiva/Attiva Elementi DCL necessari
;;; --------------------------------------------------------------------------------- ;;;
(defun congela (/)
; = CreDimScala "1"
(mode_tile "$LAY" 1)
(mode_tile "$WS" 0)
(mode_tile "$RET" 1)
(mode_tile "$CER" 1)
(mode_tile "$ELI" 1)
(mode_tile "$POL" 1)
(mode_tile "$DST" 0)
)
(defun scongela (/)
; = CreDimScala "0"
(mode_tile "$LAY" 0)
(mode_tile "$WS" 0)
(mode_tile "$RET" 0)
(mode_tile "$CER" 0)
(mode_tile "$ELI" 0)
(mode_tile "$POL" 0)
(mode_tile "$DST" 1)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; XDAdd aggiunge informazioni XDATA all'ultima entitא disegnata
;;; Xdata di Unitא e Scala della finestra creata
;;; --------------------------------------------------------------------------------- ;;;
(defun XDAdd ( / VlaxEntity xdatas DxfTypes)
;;; selezione l'ultimo oggetto creato
(setq VlaxEntity (vlax-ename->vla-object (entlast)))
;;;imposta i valori per Xdata
(setq xdatas (BuildArrays '(1001 1000 1000)
(list "CreaFinLay" (strcat "Drawing Units " UnitXD) (strcat "Scale " Sca))
)
)
(setq DxfTypes (nth 0 xdatas) DxfValues (nth 1 xdatas))
;;;aggiorna il valore dxf nell'oggetto
(vla-setXData VlaxEntity DxfTypes DxfValues)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; BuildArrays funzione utilizzata da XDAdd
;;; Autodesk "XDATA_VARIANTS.LSP"
;;; --------------------------------------------------------------------------------- ;;;
(defun BuildArrays (DxfTypes dxfValues / ListLength Counter Code VarValue
ArrayTypes ArrayValues VarTypes VarValues
Result)
;; Get length of the lists
(setq ListLength (1- (length DxfTypes)))
;; Create the safearrays for the dxf group code and value
(setq ArrayTypes (vlax-make-safearray vlax-vbInteger (cons 0 ListLength))
ArrayValues (vlax-make-safearray vlax-vbVariant (cons 0 ListLength)))
;; Set the array elements
(setq Counter 0)
(while ( "Scala le quote al Layout"
;;; La quotatura deve avvenire dal Layout nella rispettiva finestra scalata
;;; ogni finestra avrא le quote scalate nelle rispettive proporzioni.
;;; Secondo la norma "UNI EN ISO 3098-0" La gamma delle dimensioni nominali
;;; per le altezze di scrittura ט: 1,8 mm; 2,5 mm; 3,5 mm; 5 mm; 7 mm; 10 mm; 14 mm; 20 mm.
;;; --------------------------------------------------------------------------------- ;;;
(defun StiliDIM (/)
(setq *doc* (vla-get-activedocument (vlax-get-acad-object)) *dims* (vla-get-dimstyles *doc*))
;Stile ARCHITETTONICO
(setq StyDimARCHI (cdr (assoc 2(tblsearch "dimstyle" "Architectural"))))
(if (not StyDimARCHI)
(DimSetup "Architectural"
'(("DIMASZ" 2) ;;; Dimensione freccia
("DIMBLK" "_Small") ;;; Freccia
("DIMCLRT" 4) ;;; Colore testo
("DIMDEC" 0) ;;; Precisione
("DIMDLE" 1.25) ;; Estensione linea di quota
("DIMDLI" 8) ;;; Spaziatura linea di quota
("DIMEXE" 1.25) ;; Estensione linea d'estensione:
("DIMEXO" 5) ;;; Offset linea d'estensione
("DIMATFIT" 1) ;;; disposizione testo e frecce
("DIMGAP" 0.5) ;;; Offset testo
("DIMLFAC" 100) ;;; Scala lunghezza (misure in cm)
("DIMSCALE" 0) ;;; Scala generale
("DIMTMOVE" 2) ;;; Add: spostamento testo
("DIMTOFL" 1) ;;; Forza la linea entro le linee di estensione
("DIMTOH" 1) ;;; Allineamento testo esterno
("DIMTXSTY" "Dim") ;;; Stile di testo
("DIMTXT" 2.5) ;;; Altezza del testo
("DIMZIN" 0) ;;; Soppressione degli zeri
("DIMTIX" 1) ;;; Disegna il testo tra le linee di estensione
("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
; Stile MECCANICO
(setq StyDimMECCA (cdr (assoc 2(tblsearch "dimstyle" "Mechanical"))))
(if (not StyDimMECCA)
(DimSetup "Mechanical"
'(("DIMASZ" 2.5) ;;; Dimensione freccia
("DIMBLK" ".") ;;; Freccia
("DIMCLRT" 4) ;;; Colore testo
("DIMDEC" 0) ;;; Precisione
("DIMDLE" 0) ;;; Estensione linea di quota
("DIMDLI" 8) ;;; Spaziatura linea di quota
("DIMEXE" 1.25) ;; Estensione linea d'estensione:
("DIMEXO" 1) ;;; Offset linea d'estensione
("DIMATFIT" 1) ;;; disposizione testo e frecce
("DIMGAP" 0.5) ;;; Offset testo
("DIMLFAC" 1000) ;;; Scala lunghezza (misure in mm)
("DIMSCALE" 0) ;;; Scala generale
("DIMTMOVE" 2) ;;; Add: spostamento testo
("DIMTOFL" 1) ;;; Forza la linea entro le linee di estensione
("DIMTOH" 1) ;;; Allineamento testo esterno
("DIMTXSTY" "Dim") ;;; Stile di testo
("DIMTXT" 2.5) ;;; Altezza del testo
("DIMZIN" 0) ;;; Soppressione degli zeri
("DIMTIX" 1) ;;; Disegna il testo tra le linee di estensione
("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
; Stile STANDARD
(setq StyDimSTAND (cdr (assoc 2(tblsearch "dimstyle" "cf-Standard"))))
(if (not StyDimSTAND)
(DimSetup "cf-Standard"
'(("DIMASZ" 2.5) ;;; Dimensione freccia
("DIMBLK" ".") ;;; Freccia
("DIMCLRT" 4) ;;; Colore testo
("DIMDEC" 2) ;;; Precisione
("DIMDLE" 0) ;;; Estensione linea di quota
("DIMDLI" 8) ;;; Spaziatura linea di quota
("DIMEXE" 1.25) ;; Estensione linea d'estensione:
("DIMEXO" 1) ;;; Offset linea d'estensione
("DIMATFIT" 1) ;;; disposizione testo e frecce
("DIMGAP" 0.5) ;;; Offset testo
("DIMLFAC" 1) ;;; Scala lunghezza (misure in m)
("DIMSCALE" 0) ;;; Scala generale
("DIMTMOVE" 2) ;;; Add: spostamento testo
("DIMTOFL" 1) ;;; Forza la linea entro le linee di estensione
("DIMTOH" 1) ;;; Allineamento testo esterno
("DIMTXSTY" "Dim") ;;; Stile di testo
("DIMTXT" 2.5) ;;; Altezza del testo
("DIMZIN" 0) ;;; Soppressione degli zeri
("DIMTIX" 1) ;;; Disegna il testo tra le linee di estensione
("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
)
;;; fine StiliDIM

;;; --------------------------------------------------------------------------------- ;;;
;;; Lista Stili Quota non generati da "CreaStyDim"
;;; is request to load AI_UTILS
;;; --------------------------------------------------------------------------------- ;;;
(Defun ListaDimStili (/)
(setq ListaDS nil)
(setq Index 0)
(setq p nil)
(setq dimstyle_names (acad_strlsort (ai_table "DIMSTYLE" 0)))
(progn
(while (nth index dimstyle_names)
(Progn
(setq p (nth index dimstyle_names))
(vl-string-search "k" p)
(if (= (vl-string-search "k" p) nil)
(setq ListaDS (append ListaDS (list p)))
)
(setq index (+ 1 index))
)
)
)
(setq index 0)
;;; fine creazione lista Stili quota
(start_list "$DST")
(mapcar 'add_list ListaDS)
(end_list)
(if (or(= DS_nlst nil) (> DS_nlst (length ListaDS)))
(if (member "cfStandard" ListaDS)
(set_tile "$DST" (itoa (vl-position "cf-Standard" ListaDS)))
(set_tile "$DST" "0")
)
(set_tile "$DST" (itoa DS_nlst))
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;;;;; CreaStyDim predispone lo stile di quota
;;; --------------------------------------------------------------------------------- ;;;
(defun CreaStyDim (/)
(setq PrefStyDim (strcat (substr (getvar "dimstyle") 1 3)" "))
(setq NewDim (strcat PrefStyDim Unit$ " " (vl-string-subst "k" ":" Sca))
StyDim (cdr (assoc 2(tblsearch "dimstyle" NewDim)))
)
(cond
((not StyDim)
(if (or (= "cfA " PrefStyDim) (= "cfM " PrefStyDim))
(setq Dim_Dec 0) ; 0 Cifre decimali
(setq Dim_Dec 2) ; 2 Cifre decimali (= "m" Unit$)
)

(DimSetup NewDim
(list (list "DIMDEC" Dim_Dec) ;;; Precisione
(list "DIMSCALE" (/ 1 (distof FattZoom 2))) ;;; Scala generale
(cond
((and (= "cfA " PrefStyDim) (= "m" Unit$)) '("DIMLFAC" 100)) ;;; Scala lunghezza (misure in m)
((and (= "cfA " PrefStyDim)(= "cm" Unit$)) '("DIMLFAC" 1))
((and (= "cfA " PrefStyDim)(= "mm" Unit$)) '("DIMLFAC" 0.1))

((and (= "cfM " PrefStyDim)(= "m" Unit$)) '("DIMLFAC" 1000))
((and (= "cfM " PrefStyDim)(= "cm" Unit$)) '("DIMLFAC" 10))
((and (= "cfM " PrefStyDim)(= "mm" Unit$)) '("DIMLFAC" 0.1))

((and (= "cfS " PrefStyDim)(= "m" Unit$)) '("DIMLFAC" 1))
((and (= "cfS " PrefStyDim)(= "cm" Unit$)) '("DIMLFAC" 0.01))
((and (= "cfS " PrefStyDim)(= "mm" Unit$)) '("DIMLFAC" 0.001))

( T '("DIMLFAC" 1))
)
'("DIMTOH" 1) ;;; Allineamento testo esterno
'("DIMTXSTY" "Dim") ;;; Stile di testo
'("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
'("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
)
)

;;; --------------------------------------------------------------------------------- ;;;
; Set current dim style by lisp command
; Tharwat - http://www.cadtutor.net
; uso (_SetDimStyleCurrent "cfArchitettonico")
;;; --------------------------------------------------------------------------------- ;;;
(defun _SetDimStyleCurrent (dim / acdoc)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(if (tblsearch "DIMSTYLE" dim)
(vla-put-activeDimstyle
acdoc
(vla-item (vla-get-Dimstyles acdoc) dim)
)
)
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; lista layout
;;; --------------------------------------------------------------------------------- ;;;
;; ר GetLays ר (Lee Mac) ;;
;; ~ Retrieves a list of Layout VLA-Objects, ;;
;; excluding the Model tab, sorted in Tab order. ;;

(defun GetLays (/ lst)
(or lay (setq lay (vla-get-layouts
(vla-get-ActiveDocument
(vlax-get-acad-object)))))

(vlax-for ly lay
(and (not (eq "Model" (vla-get-Name ly)))
(setq lst (cons ly lst))))

(vl-sort lst
(function
(lambda (a b)
( Lay_nlst (length L_LAY)))
(set_tile "$LAY" "0")
(set_tile "$LAY" (itoa Lay_nlst))
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; immagine logo Generata da VECTORIZE.lsp di Richard Willis
;;; ;********************************************************************************
;;; ; Function to draw a vector image within a dialogue Image tile or Image Button. *
;;; ; Argument: 'DCLKEY' - the dcl key of the image tile/button to be filled. *
;;; ; Do NOT edit the dcl dimension text below, this is needed by Vectorize. *
;;; ;********************************************************************************
;;; ; Compiled for dcl dimensions of width,8.26, height,3.82, *
;;; ;********************************************************************************
;;; --------------------------------------------------------------------------------- ;;;
(defun LogoCFL (DCLKEY / i j)
(setq i (/ (dimx_tile DCLKEY) 51.) j (/ (dimy_tile DCLKEY) 51.))
(start_image DCLKEY)
(fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -15)
(foreach x '((5 10 7 10 250) (7 10 7 7 250) (7 7 5 7 250) (5 7 5 10 250)
(6 9 6 2 250) (6 9 13 9 250) (6 9 6 15 250) (6 9 0 9 250)
(4 40 5 41 1) (5 41 5 41 1) (5 41 6 41 1) (6 41 6 41 1)
(6 41 6 40 1) (6 40 6 40 1) (6 40 6 40 1) (6 40 5 40 1)
(5 40 4 40 1) (4 40 3 40 1) (3 40 3 40 1) (3 40 2 40 1)
(2 40 2 40 1) (2 40 2 40 1) (2 40 1 41 1) (1 41 1 42 1)
(1 42 1 42 1) (1 42 1 43 1) (1 43 2 43 1) (2 43 2 44 1)
(2 44 5 45 1) (5 45 5 45 1) (5 45 5 46 1) (5 46 6 46 1)
(6 46 6 47 1) (6 47 5 47 1) (5 47 5 47 1) (5 47 4 48 1)
(4 48 4 48 1) (4 48 3 47 1) (3 47 2 47 1) (2 47 2 47 1)
(2 47 2 47 1) (2 47 1 47 1) (1 47 1 47 1) (1 47 1 48 1)
(1 48 1 48 1) (1 48 2 48 1) (2 48 3 48 1) (3 48 4 48 1)
(4 48 4 49 1) (4 49 5 48 1) (5 48 5 48 1) (5 48 6 48 1)
(6 48 6 48 1) (6 48 6 47 1) (6 47 7 46 1) (7 46 7 46 1)
(7 46 6 45 1) (6 45 6 45 1) (6 45 5 44 1) (5 44 3 43 1)
(3 43 2 42 1) (2 42 2 42 1) (2 42 2 41 1) (2 41 2 41 1)
(2 41 3 41 1) (3 41 3 40 1) (3 40 4 40 1) (10 42 10 42 1)
(10 42 9 43 1) (9 43 9 43 1) (9 43 8 44 1) (8 44 8 47 1)
(8 47 8 47 1) (8 47 9 48 1) (9 48 9 48 1) (9 48 10 49 1)
(10 49 12 49 1) (12 49 12 48 1) (12 48 12 48 1) (12 48 12 48 1)
(12 48 10 48 1) (10 48 10 47 1) (10 47 9 47 1) (9 47 9 44 1)
(9 44 10 43 1) (10 43 10 43 1) (10 43 12 43 1) (12 43 12 43 1)
(12 43 12 43 1) (12 43 12 43 1) (12 43 12 42 1) (12 42 10 42 1)
(14 46 14 47 1) (14 47 14 47 1) (14 47 14 48 1) (14 48 15 48 1)
(15 48 16 49 1) (16 49 18 49 1) (18 49 18 48 1) (18 48 18 44 1)
(18 44 18 43 1) (18 43 18 43 1) (18 43 17 42 1) (17 42 16 42 1)
(16 42 15 42 1) (15 42 14 43 1) (14 43 14 43 1) (14 43 15 43 1)
(15 43 16 43 1) (16 43 17 43 1) (17 43 17 44 1) (17 44 17 45 1)
(17 45 16 45 1) (16 45 15 45 1) (15 45 15 45 1) (15 45 14 46 1)
(14 46 14 46 1) (15 47 15 47 1) (15 47 15 46 1) (15 46 16 46 1)
(16 46 17 46 1) (17 46 17 48 1) (17 48 16 48 1) (16 48 15 47 1)
(20 40 20 40 1) (20 40 20 47 1) (20 47 20 47 1) (20 47 20 48 1)
(20 48 21 48 1) (21 48 21 49 1) (21 49 21 49 1) (21 49 22 48 1)
(22 48 21 47 1) (21 47 21 40 1) (21 40 21 40 1) (21 40 20 40 1)
(25 47 25 47 1) (25 47 25 46 1) (25 46 25 46 1) (25 46 27 46 1)
(27 46 27 48 1) (27 48 25 48 1) (25 48 25 47 1) (37 48 38 49 1)
(38 49 38 49 1) (38 49 38 48 1) (38 48 38 40 1) (38 40 38 40 1)
(38 40 37 40 1) (37 40 35 41 1) (35 41 35 42 1) (35 42 35 42 1)
(35 42 36 42 1) (36 42 36 42 1) (36 42 37 41 1) (37 41 37 48 1)
(24 46 24 47 1) (24 47 24 47 1) (24 47 24 48 1) (24 48 25 48 1)
(25 48 25 49 1) (25 49 28 49 1) (28 49 28 48 1) (28 48 28 44 1)
(28 44 28 43 1) (28 43 28 43 1) (28 43 27 42 1) (27 42 26 42 1)
(26 42 25 42 1) (25 42 24 43 1) (24 43 24 43 1) (24 43 25 43 1)
(25 43 26 43 1) (26 43 27 43 1) (27 43 27 44 1) (27 44 27 45 1)
(27 45 25 45 1) (25 45 25 45 1) (25 45 24 45 1) (24 45 24 46 1)
(24 46 24 46 1) (40 47 40 47 1) (40 47 40 47 1) (40 47 40 48 1)
(40 48 40 48 1) (40 48 40 48 1) (40 48 41 48 1) (41 48 41 47 1)
(41 47 40 47 1) (40 47 40 47 1) (40 47 40 47 1) (40 47 40 47 1)
(40 47 40 47 1) (40 47 40 47 1) (40 47 40 47 1) (40 43 40 44 1)
(40 44 40 44 1) (40 44 40 44 1) (40 44 40 44 1) (40 44 41 44 1)
(41 44 41 44 1) (41 44 40 43 1) (40 43 40 43 1) (40 44 40 44 1)
(40 44 40 44 1) (40 44 40 44 1) (40 44 40 44 1) (40 44 40 44 1)
(40 44 40 44 1) (46 45 50 45 30) (50 45 50 17 30) (50 17 15 17 30)
(15 17 15 38 30))
(vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x))
)
(end_image)
(princ)
);_fine LogoCFL

;;; --------------------------------------------------------------------------------- ;;;
;;;Controllo Unitא Disegno
;;; --------------------------------------------------------------------------------- ;;;
(defun m_cm_mm (/)
(if(not Unit$)
(progn
(setq Unit$ "m" Convert 1000.0 UnitXD "Meter")
(mode_tile "$M" 2)
)
)
(if(= "m" Unit$)
(progn
(setq Convert 1000.0 UnitXD "Meter")
(mode_tile "$M" 2)
)
)
(if(= "cm" Unit$)
(progn
(setq Convert 10.0 UnitXD "Cantimeter")
(mode_tile "$CM" 2)
)
)
(if(= "mm" Unit$)
(progn
(setq Convert 1.0 UnitXD "Millimeter")
(mode_tile "$MM" 2)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Controllo Forma della finestra di layout
;;; --------------------------------------------------------------------------------- ;;;
(defun FormaFin (/)
(if (not Forma$)
(progn
(setq Forma$ "RET")
(mode_tile "$RET" 2)
)
)
(if (= "RET" Forma$)
(progn
(setq Forma$ "RET")
(mode_tile "$RET" 2)
)
)
(if (= "CER" Forma$)
(progn
(setq Forma$ "CER")
(mode_tile "$CER" 2)
)
)
(if (= "ELI" Forma$)
(progn
(setq Forma$ "ELI")
(mode_tile "$ELI" 2)
)
)
(if (= "POL" Forma$)
(progn
(setq Forma$ "POL")
(mode_tile "$POL" 2)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Controllo Rotazione vista della finestra di layout
;;; --------------------------------------------------------------------------------- ;;;
(defun RotVP0 (/)
(cond ((/= (getvar "viewtwist") 0)
(command "_.dview" "_c" (getvar "vsmax") (getvar "vsmin") "" "_tw" 0 "")
(setvar "SNApang" 0)
)
)
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Cancella VIEWPORT esistenti
;;; --------------------------------------------------------------------------------- ;;;
(defun CancVport (/)
(progn (setq ssvp (ssget "X" '((0 . "VIEWPORT"))))
(setq n 0)
(if ssvp
(while (> Assume using Viewport layer for viewport frames, change code value here if needed <> Set viewport border offset from actual detail, change code value here if needed <<==
(setvar "osmode" 16416) ; Turn osnap off
(if (/= cp "Model") ; Must be started from a layout tab to establish destination, quit quietly if on Model tab
(progn
(princ "\n") ; Clean up command line
(setq vplyes 0) ; Assume viewport doesn't exist
(setq l0 (tblnext "LAYER" 1)) ; Get past 0 layer in layer list
(while (setq layers (tblnext "LAYER")) ; Loop through layer list collection
(setq ln (cdr (assoc 2 layers))) ; Extract layer name from list
(if (= (strcase ln) (strcase vpl)) (setq vplyes 1)) ; Check if viewport layer exists
)
(if (= vplyes 0) (command "layer" "NEW" vpl "COLOR" "1" vpl "")) ; Make viewport layer and assign color to red if doesn't exist
(setvar "clayer" vpl) ; Change to viewport layer
(command "layer" "ON" (strcat "0," vpl) "UNLOCK" (strcat "0," vpl) "") ; Turn on and unlock viewport and 0 layer
(command "zoom" "e") ; View entire layout tab
(setvar "ctab" "Model") ; Activate Model tab
; (command "zoom" "e") ; View entire Model Space area
(setq vpc1 (getpoint "\nSpecify first corner of model space window area: ")) ; Just pick rough area including all relavent details, will fine-tune border area later in Paper Space
(if vpc1 ; Quietly quit if no point specified
(progn
(setq vpc2 (getcorner vpc1 "\nSpecify opposite corner of model space window area: ")) ; Window rectangle can be designated in any direction
(if vpc2 ; Quietly quit if no point specified
(progn
(princ "\n") ; Clean up command line
(setvar "ctab" cp) ; Return to layout tab program was started from
(command "pspace") ; Switch to Paper Space of layout tab
(setq svpc (getpoint "\nSpecify destination of paper space viewport center: ")) ; Can't change layout tabs manually here
(if svpc ; Quietly quit if no point specified
(progn
(setq sf (getreal "\nViewport zoom scale factor : ")) ; Default to full-scale if no value is inputted
(if (= sf nil) (setq sf 1.0) (setq sf (abs sf))) ; Make sure scale factor is positive number
(setq vpxd (* sf (abs (- (car vpc2) (car vpc1))))) ; Determine horizontal length of selected window
(setq vpyd (* sf (abs (- (cadr vpc2) (cadr vpc1))))) ; Determine vertical height of selected window
(setq vpc (list (/ (+ (car vpc1) (car vpc2)) 2.0) (/ (+ (cadr vpc1) (cadr vpc2)) 2.0) 0.0)) ; Determine center point of selected model window
(command "mview" (list (- (car svpc) (/ vpxd 2.0)) (- (cadr svpc) (/ vpyd 2.0))) (strcat "@" (rtos vpxd) "," (rtos vpyd))) ; Create Paper Space viewport
(setq ssvp (ssget "L")) ; Start selection set with last viewport frame
(setq ssvp1 (ssget "L")) ; Another copy of viewport frame selection set
(command "mspace") ; Open viewport window to Model Space
(command "ucsicon" "ON") ; Turn on UCS icon for viewport
(command "ucs" "WORLD") ; Reset UCS to WCS
(command "zoom" "C" vpc (rtos vpyd)) ; Center view of viewport window using determined point
(command "zoom" "SCALE" (strcat (rtos sf) "XP")) ; Set zoom scale of viewport window
(command "vports" "LOCK" "ON" ssvp "") ; Lock scale and position of model in viewport
(command "pspace") ; Close viewport window
(command "zoom" (list (- (car svpc) (/ vpxd 2.0)) (- (cadr svpc) (/ vpyd 2.0))) (strcat "@" (rtos vpxd) "," (rtos vpyd))) ; Zoom in on just created viewport extremes
(command "zoom" "0.95X") ; Back zoom off slightly to see edges clearly
(setq lpno 2) ; Loop counter for making separate viewports
(setq vpno (getint "\nNumber of separate viewports to make from this viewport : ")) ; Will divide single viewport into separate viewports for othagonal views of 2D part
(if (>= vpno 2) ; Proceed to copy current viewport if 2 or more separate viewports desired
(progn
(while (<= lpno vpno) ; Check if viewport loop counter less than number of viewports desired
(command "copy" ssvp "" "0,0" "@0,0") ; Make copy of new viewport laying exactly on top of first viewport
(setq lpno (1+ lpno)) ; Increment viewport loop counter
(ssadd (entlast) ssvp1) ; Add viewport copy to selection set
)
)
)
(setq ssnum 0) ; Loop counter for fine-tuning separate viewports
(while (= vpno 2) ; Check for multiple viewports
(setq clt (strcat " #" (rtos (+ ssnum 1) 2 0))) ; Make command prompt string if using multiple viewports
(setq clt "") ; Make command prompt string if using single viewport
)
(initget 128) ; Enable string responses from point prompt
(setvar "osmode" 32)
(setq nvpc1 (getpoint (strcat "\nSpecify first corner of viewport" clt " window area or [Center point of circle]: "))) ; Pick actual part corner, program will apply offset
(if nvpc1 ; Will repeat asking for first corner if none specified
(progn
(if (= 'STR (type nvpc1)) ; Check if string was inputted instead of corner point
(progn
(if (= "C" (strcase (substr nvpc1 1 1))) ; Check if asking for circular viewport area
(progn
(setq nvpc1 (getpoint (strcat "\nSpecify center of viewport" clt " window area: "))) ; Pick center of separate circular viewport window
(if nvpc1 ; Will return to asking for first corner if center not specified
(progn
(setvar "osmode" 0) ; Turn osnap off
(princ (strcat "\nSpecify radius of viewport" clt " window area: ")) ; Make command prompt for circle viewport
(command "circle" nvpc1 pause) ; Make circle to clip existing viewport
(setvar "osmode" 2559) ; Turn osnap on
(setq ssvp (ssget "L")) ; Select last circle
(command "vpclip" vpent ssvp) ; Clip existing viewport to circle
(setq ssnum (1+ ssnum)) ; Increment fine-tuned viewport loop counter
)
)
)
)
)
(progn
(setq nvpc2 (getcorner nvpc1 (strcat "\nSpecify opposite corner of viewport" clt " window area: "))) ; Window rectangle can be designated in any direction, pick actual part corner, program will apply offset
(if nvpc2 ; Will repeat asking for first corner if none specified
(progn
(setq nvpc1x (car nvpc1)) ; Find X portion of first corner
(setq nvpc1y (cadr nvpc1)) ; Find Y portion of first corner
(setq nvpc2x (car nvpc2)) ; Find X portion of second corner
(setq nvpc2y (cadr nvpc2)) ; Find Y portion of second corner
(if (> nvpc2x nvpc1x) ; Determine horizontal direction of viewport window rectangle
(progn
(setq nvpc2x (+ nvpc2x ofs)) ; Add horizontal offset to right of specified left-to-right window rectangle
(setq nvpc1x (- nvpc1x ofs)) ; Add horizontal offset to left of specified left-to-right window rectangle
)
(progn
(setq nvpc2x (- nvpc2x ofs)) ; Add horizontal offset to left of specified right-to-left window rectangle
(setq nvpc1x (+ nvpc1x ofs)) ; Add horizontal offset to right of specified right-to-left window rectangle
)
)
(if (> nvpc2y nvpc1y) ; Determine vertical direction of viewport window rectangle
(progn
(setq nvpc2y (+ nvpc2y ofs)) ; Add vertical offset to top of specified lower-to-upper window rectangle
(setq nvpc1y (- nvpc1y ofs)) ; Add vertical offset to bottom of specified lower-to-upper window rectangle
)
(progn
(setq nvpc2y (- nvpc2y ofs)) ; Add vertical offset to bottom of specified upper-to-lower window rectangle
(setq nvpc1y (+ nvpc1y ofs)) ; Add vertical offset to top of specified upper-to-lower window rectangle
)
)
(setvar "osmode" 0) ; Turn osnap off
(command "rectang" (list nvpc1x nvpc1y) (list nvpc2x nvpc2y)) ; Make rectangle with offset to clip existing viewport
(setvar "osmode" 2559) ; Turn osnap on
(setq ssvp (ssget "L")) ; Select last rectange
(command "vpclip" vpent ssvp) ; Clip existing viewport to rectangle
(command "vpclip" ssvp "d" ) ; Convert Polygonal Vport to Rectangular
(setq ssnum (1+ ssnum)) ; Increment fine-tuned viewport loop counter
)
)
)
)
)
)
)
)
)
)
)
)
)
)
(princ "\nThis command must be started from a layout sheet!") ; Need to start on a layout tab so program knows where to create the new viewports
)
(setvar "ctab" cp) ; Reset to stored tab name
(setvar "clayer" cl) ; Reset to stored layer name
(setvar "osmode" cs) ; Reset to stored osnap mode
(setvar "cmdecho" 1) ; Turn on command line echoing
(princ) ; Clean up and exit
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra Cerchio
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportCER (/ Pt1 Centro Radius RadiusLay)
(setvar "clayer" LayFIN)
(setq Pt1(getpoint "\nSpecify center point of circle: "))
(princ "\nSpecify radius of circle: ")
(command "_.circle" Pt1 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq Radius (cdr (assoc 40 Ent)))
(command "_.erase" entname "")
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Add")
(progn
(setq RadiusLay (* Radius (atof FattZoom)))
(setvar "osmode" 0)
(command "_.circle" (strcat (rtos RadiusLay) "," (rtos RadiusLay)) RadiusLay)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(command "_.-vports" "_o" Entname)
(setq NumVP (cdr (assoc 69 Ent)))
(setq Wc1 (POLAR (list (* 1.4142 RadiusLay) (* 1.4142 RadiusLay) 0.0) (/ (* 5 PI) 4) RadiusLay))
(setq Wc2 (POLAR (list (* 1.4142 RadiusLay) (* 1.4142 RadiusLay) 0.0) (/ PI 4) RadiusLay))
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(Command "zoom" "_c" Pt1 ScXP)
(command "_.pspace")
(Command "zoom" "_all")
(command "_.dragmode" "_auto")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" Entname "" (strcat (rtos RadiusLay) "," (rtos RadiusLay)) pause)
(command "_.mview" "_l" "_on" Entname "")
)
);fine IF /= Add
(if (= SCA "Add")
(progn
(setq Wc1 (getpoint "\nSpecify center point of circle: "))
(princ "\nSpecify radius of circle: ")
(command "_.circle" Wc1 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq RadiusLay (cdr (assoc 40 Ent)))
(command "_.-vports" "_o" Entname)
(setq NumVP (cdr (assoc 69 Ent)))
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" (POLAR PT1 (/ (* 5 PI) 4) (* 1.4142 Radius)) (POLAR PT1 (/ PI 4) (* 1.4142 Radius)))
(command "_.pspace")
(Command "zoom" "_all")
(command "_.mview" "_l" "_on" Entname "")
(setq WriteScala "0")
)
);fine IF Add
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra Ellisse
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportELI (/ Ang Diag Pt1 Pt2Lay PtMed Centro CentroLay MDiag2 Mdiag2Lay
Pt1R Rap)
(if (/= "PELLIPSE" 0)(setvar "PELLIPSE" 0))
;0 Crea un oggetto ellisse vero.
;1 Crea la rappresentazione di un'ellisse in forma di polilinea
(setvar "clayer" LayFIN)
(setq Pt1(getpoint "\nSpecifies the start point of the axis: "))
(setq Pt2(getpoint Pt1 "\nSpecifies the end point of the axis: "))
(princ "\nSpecifies the length of the Second half-axis: ")
(command "_.ellipse" Pt1 Pt2 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq Centro (cdr (assoc 10 Ent)))
(setq Rap (cdr (assoc 40 Ent))) ;rapporto tra asse minore e asse maggiore
(setq Pt1R (cdr (assoc 11 Ent))) ;punto finale asse maggiore rispetto al centro
(setq Ang (angle Pt1 Pt2))
(setq Diag (distance Pt1 Pt2))
(setq PtMed (polar Pt1 Ang (/ Diag 2)))
(if (= (rtos (/ (distance Pt1 Pt2) 2)2 2) (rtos (distance '(0.0 0.0 0.0) Pt1R)2 2))
(setq MDiag2 (/ (* Diag Rap) 2))
(setq MDiag2 (/ (/ Diag Rap) 2))
)
(command "_.erase" entname "")
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Add")
(progn
(setq Pt2Lay (polar '(0 0) Ang (* (distance Pt1 Pt2) (atof FattZoom))))
(setq Mdiag2Lay (* Mdiag2 (atof FattZoom)))
(setvar "osmode" 0)
(command "_.ellipse" "0,0" Pt2Lay Mdiag2Lay)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq CentroLay (cdr (assoc 10 Ent)))
(setq PtRagMag (cdr (assoc 11 Ent)))
(command "_.-vports" "_o" Entname)
(setq EntVP (entget (entlast)));; setta viewport
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
(setq Wc1 (list (- (car PC_SC)(/ Larg_SC 2))(- (cadr PC_SC) (/ Alt_SC 2))))
(setq Wc2 (list (+ (car PC_SC)(/ Larg_SC 2))(+ (cadr PC_SC) (/ Alt_SC 2))))
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;;controlla rotazione vista nella finestra
(command "_.zoom" "_c" Ptmed ScXP)
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" Entname "" CentroLay pause)
(command "_.mview" "_l" "_on" Entname "")
)
);fine IF /= Add
(if (= SCA "Add")
(progn
(setq Wc1 (getpoint "\nSpecify the center of the ellipse: "))
(princ "\nSpecify the length of the major semi-axis: ")
(setq Wc2 (strcat "@" (rtos (car Pt1R))"," (rtos (cadr Pt1R))))
(setvar "osmode" 0)
(command "_.ellipse" "_c" Wc1 Wc2 Mdiag2)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(command "_.-vports" "_o" Entname)
(setq EntVP (entget (entlast)));; setta viewport
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
(setq Wc1M (list (- (car Centro)(/ Larg_SC 2))(- (cadr Centro) (/ Alt_SC 2))))
(setq Wc2M (list (+ (car Centro)(/ Larg_SC 2))(+ (cadr Centro) (/ Alt_SC 2))))
(command "_.dragmode" "_auto")
(command "_.Scale" Entname "" Wc1 "_r" Wc1 Wc2 pause)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" (trans Wc1M 0 1) (trans Wc2M 0 1))
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(command "_.mview" "_l" "_on" Entname "")
(setq WriteScala "0")
)
);fine IF Add
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra Polilinea
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportPOL (/ Pt1)
(setvar "clayer" LayFIN)
;(command "_.undo" "_be")
(princ "\n.....Draw Polyline ")
(setq Pt1 (getpoint "\nFrom Point: "))
(princ "\nNext Point [Undo / ]: ")
(command "_.pline" Pt1 pause)
(while (> (getvar "cmdactive") 0)
(progn
(princ "\nNext Point [Undo / ]]: ")
(command pause))
)
(command "_.pedit" "_l" "_c" "_x")
;(command "_.undo" "_e")
(setq Ent (entget (entlast)))
(setq EntNamePModel (cdr (assoc -1 Ent)))
(ListaVertPL_CFL)
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Add")
(progn
(setvar "osmode" 0)
(NDrawListaVerticiPOL)
(setq Ent (entget (entlast)))
(setq EntNamePLay (cdr (assoc -1 Ent)))
(command "_.scale" EntNamePLay "" "0,0" FattZoom)
(command "_.-vports" "_o" EntNamePLay)
(setq EntVP (entget (entlast)));; setta viewport
(setq EntNamePLayVP (cdr (assoc -1 EntVP))) ;; nome
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
;(setq PC_SM (cdr (assoc 12 EntVP))) ;; punto centrale VP nello spazio modello
(setq NumVP (cdr (assoc 69 EntVP)))
(setq Wc1 (list (- (car PC_SC)(/ Larg_SC 2))(- (cadr PC_SC) (/ Alt_SC 2))))
(setq Wc2 (list (+ (car PC_SC)(/ Larg_SC 2))(+ (cadr PC_SC) (/ Alt_SC 2))))
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_c" PtCen ScXP)
(command "_.erase" EntNamePModel "")
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" EntNamePLay "" "0,0" pause)
(command "_.mview" "_l" "_on" EntNamePLay "")
)
);fine IF /= Add
(if (= SCA "Add")
(progn
(setvar "osmode" 0)
(setq Wc0 (getpoint "\nSpecify the position of the first point of the polygon: "))
(command "_.ucs" "_n" Wc0)
(NDrawListaVerticiPOL)
(setq Ent (entget (entlast)))
(setq EntNamePLay (cdr (assoc -1 Ent)))
(command "_.-vports" "_o" EntNamePLay)
(setq EntVP (entget (entlast)));; setta viewport
(setq EntNamePLayVP (cdr (assoc -1 EntVP))) ;; nome
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
;(setq PC_SM (cdr (assoc 12 EntVP))) ;; punto centrale VP nello spazio modello
(setq NumVP (cdr (assoc 69 EntVP)))
(setq Wc1 (list (- (car PC_SC)(/ Larg_SC 2))(- (cadr PC_SC) (/ Alt_SC 2))))
(setq Wc2 (list (+ (car PC_SC)(/ Larg_SC 2))(+ (cadr PC_SC) (/ Alt_SC 2))))
(princ "\nSpecifiy the reference length for enlargement / reduction: ")
(command "_.Scale" EntNamePLay "" "0,0" "_r" (sqrt(+ (expt Larg_SC 2)(expt Alt_SC 2))) pause)
(command "_.ucs" "_W" "")
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" (trans Ptmin 0 1) (trans Ptmax 0 1))
(command "_.erase" EntNamePModel "")
(command "_.pspace")
(Command "_.zoom" "_all")
(setvar "osmode" oldsnap)
(command "_.mview" "_l" "_on" EntNamePLay "")
(setq WriteScala "0")
)
);fine IF Add
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Crea lista vertici finestra poligonale
;;; --------------------------------------------------------------------------------- ;;;
(Defun ListaVertPL_CFL (/)
(setq ListaV nil)
(setq Index 0)
(progn
(while (nth index Ent)
(Progn
(setq p (nth index Ent)) ;Direzione di estrusione
(if (= (car p) 10)
(setq ListaV (append ListaV (list (cdr p))))
)
(setq index (+ 1 index))
)
)
)
(setq ListaV (append ListaV (list (nth 0 ListaV))))
(setq nrVertici (- (length ListaV) 1))
(setq index 0)
;;;--------------------------------------------------------
;; trova coordinate minime, massime e centro finestra poligonale
;;(Defun Lista_minmax_XY (/)
(setq IndexC 0)
(progn
(while (nth indexC ListaV)
(Progn
(setq pC (nth indexC ListaV))
(if (/= (car pC) nil)
(progn
(setq ListaVX (append ListaVX (list (car pC))))
(setq ListaVY (append ListaVY (list (cadr pC))))
)
)
(setq indexC (+ 1 indexC))
)
)
)
(setq ListaVX (append ListaVX (list (nth 0 ListaVX))))
(setq ListaVY (append ListaVY (list (nth 0 ListaVY))))
(setq indexC 0)

(setq minX (eval (append '(min) ListaVX))
minY (eval (append '(min) ListaVY))
maxX (eval (append '(max) ListaVX))
maxY (eval (append '(max) ListaVY)))

(setq Ptmin (list minX minY)
Ptmax (list maxX maxY))
;; trans 0 1
;; Translates a point (or a displacement) from one coordinate system to another
;;0 World (WCS) 1 User (current UCS)
(setq PtCen (trans (inters (list minX minY)(list maxX maxY)(list minX maxY)(list maxX minY))0 1))
;) ;; Fine Lista_minmax_XY
;;;--------------------------------------------------------
;;; calcola la finestra poligonale con coordinate inizio spostate nel punto 0,0
(setq IndexC 0)
(progn
(while (nth indexC ListaV)
(Progn
(setq pC (nth indexC ListaV))
(if (/= (car pC) nil)
(setq NListaV
(append NListaV
(list (list (- (car pC) (car (car ListaV)))
(- (cadr pC) (cadr (car ListaV)))
)
)
)
)
)
(setq indexC (+ 1 indexC))
)
)
)
(setq indexC 0)
);; Fine ListaVertPL_CFL
;;; --------------------------------------------------------------------------------- ;;;
;;; disegna polilinea da lista vertici
;;; --------------------------------------------------------------------------------- ;;;
(defun NDrawListaVerticiPOL (/)
(command "_.pline")
(apply 'command NListaV)
(command "")
(command "_.pedit" "_l" "_c" "_x")
)
;;; --------------------------------------------------------------------------------- ;;;
;;; calcola ScalaFinLay
;;; --------------------------------------------------------------------------------- ;;;
(defun ScalaFinLay(/)
(setq Sca_nlst (atoi (get_tile "$LSCA")))
;************************************************************************
;**** se SCA = "Add" allora VALSCA =0 e FATTZOOM = "0" e SCXP = "0xp"
;************************************************************************
(setq Sca (nth Sca_nlst L_SCA))
(setq ValSca (atoi (vl-string-subst "" "1:" Sca)))
(if
(and (= 0 (vl-string-position (ascii "1") Sca)) (= 1 (vl-string-position (ascii ":") Sca)))
(setq FattZoom (CAL_RtoS (/ Convert ValSca) T)) ;; Fattore ZoomXP scala Riduzione
(setq FattZoom (CAL_RtoS (* Convert ValSca) T)) ;; Fattore ZoomXP scala ingrandimento
)
(if (/= Sca "Add")
(setq ScXP (strcat FattZoom "xp"))
(setq ScXP "Add")
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Scrive Scala con Testo Multilinea
;;; --------------------------------------------------------------------------------- ;;;
(defun ScriveScala_TM (/)
(setvar "clayer" LayAnnFIN)
(setvar "textstyle" StyTxt)
(setq $a (cons 40 5.0))
(setq $b (cons 1 (strcat "{\\L\\P\\l\\H0.7x;Scale " Sca "}"))) ;testo decrizione H 5mm sottolineato e scala H3.5mm non sottolineata
(setq $c (cons 10 '(0.0 0.0 0.0)))
(entmake (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(7 . "cfFinlay")
'(71 . 5)
'(90 . 3) ;;; Maschera di sfondo con colore sfondo disegno
'(45 . 1.2) ;;; Fattore Offset Bordo
$a $b $c
)
)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(command "_.copyclip" Entname "")
(command "_.erase" Entname "")
(setvar "CTAB" Lay)
;(princ "\nSpecify the insertion point of the Scale annotation: ")(princ)
;(command "_.pasteclip" pause)

(setq Ent (entget (entlast)))
;;; presenta il testo in modo editazione
;;; (setvar "regenmode" 0)
;;; (vl-cmdf "_.Zoom" "_c" (cdr (assoc 10 Ent)) (* (cdr (assoc 40 Ent))30))
;;; (vl-cmdf "_.ddedit" (cdr (assoc -1 Ent))"")
;;; (vl-cmdf "_.Zoom" "_p")
;;;
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Total number of viewports in current layout
;;; (1- (sslength (ssget "_X" (list '(0 . "VIEWPORT") (cons 410 (getvar "CTAB"))))))
;;; --------------------------------------------------------------------------------- ;;;
;;; calcolo Numero ViewPort in tutti i Layout
;;; --------------------------------------------------------------------------------- ;;;
(defun AllViewports (/ active_document nvp)
(setq nvp 0)
(setq active_document
(vla-get-activedocument (vlax-get-Acad-Object))
)
(vlax-for item (vla-get-blocks active_document)
(if (wcmatch (vla-get-name item) "*Paper*")
(vlax-for object item
(if (= (vla-get-objectname object) "AcDbViewport")
(Setq nvp (+ 1 nvp))
)
)
)
)
(setq NumVP (- nvp (length (layoutlist))))
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; inizio "CFL_CreaFinLay_37-DCL.lsp"
;; ***************************************************
;; created with: Dcl2Lisp.lsp by Charles Alan Butler
;; create_dcl function to create a dcl support
;; file if it does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_dcl (fn / acadfn)
(if (null(wcmatch (strcase fn) "*`.DCL"))
(setq fn (strcat fn ".DCL"))
)
(if (not (findfile (strcat (getvar "roamablerootprefix") fn)))
;; create dcl file
(progn
(setq fn (strcat (getvar "roamablerootprefix") fn)
fn (open fn "w")
)
(foreach x '(
"//------------------------------------------------------"
"// \"CreaFinLay.LSP\""
"// \"CreaFinLay.DCL\""
"//------------------------------------------------------"
"//CreaFinLayout Dialog"
"dcl_settings : default_dcl_settings { audit_level = 3; }"
"CreaFinLayout : dialog {"
"label = \" Layout ViewPort Creator (Created by Igal Averbuh 2018) \";"
"spacer ;"
" : row { "
" : column { //colonna 1"
" : row {"
" : boxed_radio_column {"
" label = \"ViewPort Form \";"
" : radio_button {"
" label = \"Rectangle\"; "
" key = \"$RET\";"
" }"
" : radio_button {"
" label = \"Circle\"; "
" key = \"$CER\";"
" }"
" : radio_button {"
" label = \"Ellipse\"; "
" key = \"$ELI\";"
" }"
" : radio_button {"
" label = \"Polyline\"; "
" key = \"$POL\";"
" }"
" }"
" : column {"
" : boxed_radio_row {"
" label = \"Draw Units\";"
" : radio_button {"
" label = \"mm\"; "
" key = \"$MM\";"
" }"
" : radio_button {"
" label = \"cm\"; "
" key = \"$CM\";"
" }"
" : radio_button {"
" label = \"m\"; "
" key = \"$M\";"
" }"
" }"
" : boxed_column {"
" label = \"Select Scale \";"
" :row {"
" :column {"
" : text { "
" key = \"\";"
" label = \"\";"
" alignment = centered;"
" width = 20 ;"
" }"
" }"
" }"
" :row {"
" : popup_list {"
" key = \"$LSCA\"; "
" width = 15 ; fixed_width = true;"
" allow_accept = false;"
" }"
" // spacer;"
" : button { "
" width= 4; "
" fixed_width = true; "
" key=\"$EdSca\"; "
" label= \"Edit\"; "
" alignment = centered;"
" } "
" }"
" spacer;"
" }"
" }"
" }"
" :column {"
" :row { "
" : boxed_column { "
" label = \"Select Layout\";"
" : popup_list {"
" key = \"$LAY\"; "
" // width = 37; fixed_width = true;"
" allow_accept = false;"
" }"
" spacer ;"
" }"
" } "
" spacer ; "
" : row {"
" : boxed_column {"
" label = \"Optional \";"
" : toggle {"
" label = \"Annotation Scale\"; "
" key = \"$WS\"; "
" value = \"1\";"
" }"
" : toggle {"
" label = \"Create Dimmension Style\"; "
" key = \"$CSD\"; "
" value = \"0\";"
" }"
" : popup_list {"
" label = \"from Style:\";"
" key = \"$DST\"; "
" width = 30 ; "
" allow_accept = false;"
" }"
" spacer ; "
" } "
" : column {"
" spacer ;"
" }"
" : column {"
" spacer ; "
" : image {"
" alignment = centered; "
" key = \"vectors\"; "
" width = 8.26; "
" height = 3.82; "
" fixed_width = true; "
" fixed_height = true; "
" aspect_ratio = 1; "
" color = -15;"
" }"
" : text { "
" key = \"$rc0\";"
" label = \"\";"
" width = 21 ; "
" alignment = centered;"
" }"
" : text { "
" key = \"$rc1\";"
" label = \"\";"
" width = 21 ; "
" alignment = centered;"
" }"
" spacer ; "
" } //fine column"
" : column {"
" spacer ;"
" } "
" }"
" }"
" }"
" } //fine colonna 1"
" spacer ; "
" spacer ;"
" ok_cancel_help;"
"spacer ;"
"}"
""
" EditaScale : dialog { label = \" \";"
" key=\"ESLabel\";"
" spacer_1;"
" : row {"
" spacer;"
" : column { width= 18;"
" : list_box { key=\"LB1\";"
" width = 17;"
" fixed_width = true;"
" }"
" }"
" : column {"
" : edit_box { key = \"EB2\"; }"
" spacer;"
" : button { width= 12; key=\"BTA\"; label= \"Add\"; }"
" : button { width= 12; key=\"BTU\"; label= \"Modify\"; }"
" : button { width= 12; key=\"BTD\"; label= \"Delete\"; }"
" spacer;"
" spacer;"
" spacer;"
" : button { width= 12; key=\"BTR\"; label= \"Restore\"; }"
" spacer;"
" }"
" spacer;"
" }"
" spacer_1;"
" ok_cancel;"
" spacer_1;"
" }"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\n File DCL creation. "
"\n
Restart the routine again"
"\n in case of error."))
t ; return True, file created
) ; end progn
t ; return True, file found
) ; endif
) ; end defun
;;; fine "CFL_CreaFinLay_37-DCL.lsp"

;;; inizio RW_FileScale
;;; --------------------------------------------------------------------------------- ;;;
;;; lista scale da file esterno escludendo i commenti
;;; --------------------------------------------------------------------------------- ;;;
(defun LeggiFileScale(/ wPath)
(setq L_SCA (list))
(if (setq wPath (findfile "ACAD.PAT"))
(progn
(setq wPath (vl-filename-directory wPath))
(or (eq "\\" (substr wPath (strlen wPath)))
(setq wPath (strcat wPath "\\")))
t)
nil)

(cond
((not (findfile (strcat wPath Appl ".sca")))
(RestoreButton)
)
)
(setq FileRead (open (strcat wPath Appl ".sca") "r"))
(while (setq aline (read-line FileRead))
(if (/= (substr aline 1 1) "#") ;; carattere # inizio riga commento
(if (/= aline "")
(progn
(setq aline (list aline))
(setq L_SCA (append L_SCA aline))
)
)
)
)

(close FileRead)

(start_list "$LSCA")
(mapcar 'add_list L_SCA)
(end_list)

(if (or(= Sca_nlst nil) (> Sca_nlst (- (length L_SCA) 1))) ;19
;;(set_tile "$LSCA" "7") ;imposta come valore standard "1:100"
;(setq UnoCento (vl-position "1:100" L_SCA) ) ;;;Returns the index of the specified list item
(if (null (vl-position "1:100" L_SCA))
(set_tile "$LSCA" "0")
(set_tile "$LSCA" (itoa (vl-position "1:100" L_SCA)))
)
(set_tile "$LSCA" (itoa Sca_nlst))
)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Scrive lista su file riga per riga
;;; --------------------------------------------------------------------------------- ;;;
(defun ScriviFileScale(L_SCA / wPath)

(if (setq wPath (findfile "ACAD.PAT"))
(progn
(setq wPath (vl-filename-directory wPath))
(or (eq "\\" (substr wPath (strlen wPath)))
(setq wPath (strcat wPath "\\")))
t)
nil)

(setq FileWrite (open (strcat wPath Appl ".sca") "w"))
(mapcar '(lambda (Str) (write-line Str FileWrite)) L_SCA)
(close FileWrite)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; verifica digitazione nuova scala
;;; --------------------------------------------------------------------------------- ;;;
(defun VerificaSca (VSca / El VSL_sca Sx Dx MsgErrNu MsgErrDe)
(setq MsgErrNu 0
MsgErrDe 0
)
(setq VSL_sca (vl-string->list Vsca))
(setq El (ascii ":"))
(cond ((not (member El VSL_sca))
(setq MsgErrNu 1
MsgErrDe 1)
)
)
(cond ((member El VSL_sca)
(setq Sx (reverse (cdr (member El (reverse VSL_sca))))) ;; lista elementi Sx elemento scelto
(if (/= Sx nil)
(progn
(foreach n Sx
(if (/= (isdigit n) T)
(setq MsgErrNu 1)
)
) ;; end foreach
)
(setq MsgErrNu 1)
) ;fine if
(setq Dx (cdr (member El VSL_sca))) ;; lista elementi Dx elemento scelto
(if (and (/= Dx nil) (/= (car Dx) 48)) ;; non nullo e non 0 come primo numero
(progn
(foreach n Dx
(if (/= (isdigit n) T)
(setq MsgErrDe 1)
)
) ;; end foreach
)
(setq MsgErrDe 1)
) ;fine if
)
)
(cond ((and (= MsgErrNu 1) (= MsgErrDe 0))
(alert " error in the numerator!")
)
((and (= MsgErrNu 0) (= MsgErrDe 1))
(alert " error in the denominator!")
)
((and (= MsgErrNu 1) (= MsgErrDe 1))
(alert "\n Value not allowed!")
)
((and (= MsgErrNu 0) (= MsgErrDe 0))
(setq Sca Sca)
)
)
)
;;;---------------------
(defun isdigit (code)
(or
( (length localListData) 0)
(progn
(setq localListData (ArchSort localListData)) ;;;richiede "SortListLeeMac.lsp"
(start_list "LB1")
(mapcar 'add_list localListData)
(end_list)
;;;****
(cond ((= BT 0)
(if (>= (read localListPick) (length localListData))
(setq localListPick (itoa (1- (length localListData))))
)
)
((= BT 1)
(setq localListPick (itoa (vl-position TX localListData)))
)
((= BT 2)
(setq localListPick (itoa 6)) ;;; punta al valore 1:100 nel caso di ripristino scale di default
)
)
;;;**** sostuito ultima posizione LB1 con quella appena digitata nel caso di ADD
(set_tile "LB1" localListPick)
(listBoxCallBack localListPick)
)
(progn
(start_list "LB1")
;;; (add_list "* EMPTY *")
(add_list "* VUOTO *")
(end_list)
;;; (setq localListData '("*"))
(cond
((= Appl "CreaFinLay")(setq localListData '("Add")))
)
)
)
)

; Copyright ©2007 - Marc'Antonio Alessi, Italy - All rights reserved
; http://xoomer.virgilio.it/alessi
;
; Function: ALE_ReplaceFirst - 22/01/2005
;
; Version 1.01
;
; 24/01/2005 - added new local (EndLst) to correct return
; value if OldItm is not member of In_Lst
;
; Description:
; returns a copy of the list with a new item substituted
; in place of the first old item in the list
; If NewItm = nil OldItm is removed
;
; Arguments:
; NewItm = An atom or list
; OldItm = An atom or list
; In_Lst = A list
; InRLst = Original list reversed
;
; Return Values:
; A list
; the original list if OldItm is not member of the list
;
; Examples:
; (setq alist '(0 1 2 3 4 3 5 3 6 3 3 7))
;
; (ALE_ReplaceFirst "NEW" 3 alist (reverse alist))
; Returns: (0 1 2 "NEW" 4 3 5 3 6 3 3 7)
;
; (ALE_ReplaceFirst '(9 . Z) 3 alist (reverse alist))
; Returns: (0 1 2 (9 . Z) 4 3 5 3 6 3 3 7)
;
; (ALE_ReplaceFirst nil 3 alist (reverse alist))
; Returns: (0 1 2 4 3 5 3 6 3 3 7)
;
(defun ALE_ReplaceFirst (NewItm OldItm In_Lst InRLst / NthPos EndLst)
(if (setq EndLst (member OldItm In_Lst))
(progn
(setq NthPos (- (length InRLst) (length EndLst)))
(while
(/=
NthPos
(length (setq InRLst (cdr (member OldItm InRLst))))
)
)
(append (reverse InRLst) (if NewItm (list NewItm)) (cdr EndLst))
)
In_Lst
)
)

; Marc'Antonio Alessi - http://xoomer.virgilio.it/alessi
; Function: ALE_List_RemoveNth
;
; Version 2.02 - 15/02/2008 > old name: ALE_RemoveNth
; Version 1.02 - 16/06/2007
; Version 1.00 - 2001
;
; Description:
; returns a copy of the list without the nth item
;
; Arguments:
; NthPos = Integer - nth like
; In_Lst = A list
; InRLst = Original list reversed
;
; Examples:
;
; (setq alist '((0 . "A") (1 . "B") nil (3 . "D") (4 . "E") nil))
; => ((0 . "A") (1 . "B") nil (3 . "D") (4 . "E") nil)
;
; (ALE_List_RemoveNth 0 alist (reverse alist))
; => ((1 . "B") nil (3 . "D") (4 . "E") nil)
;
; (ALE_List_RemoveNth 2 alist (reverse alist))
; => ((0 . "A") (1 . "B") (3 . "D") (4 . "E") nil)
;
; (ALE_List_RemoveNth 4 alist (reverse alist))
; => ((0 . "A") (1 . "B") nil (3 . "D") nil)
;
; (ALE_List_RemoveNth 5 alist (reverse alist))
; => ((0 . "A") (1 . "B") nil (3 . "D") (4 . "E"))
;
; (ALE_List_RemoveNth 6 alist (reverse alist))
; => ((0 . "A") (1 . "B") nil (3 . "D") (4 . "E") nil)
;
;;; (setq L_SCA (list "1:1" "1:2" "1:5" "1:20" "1:25" "1:50" "1:100" "1:200" "1:250" "Add"))
;;; (ALE_List_RemoveNth 6 L_SCA (reverse L_SCA))

(defun ALE_List_RemoveNth (NthPos In_Lst InRLst / LstLng OldItm)
(cond
( (null In_Lst) nil )
( (zerop NthPos) (cdr In_Lst) )
( (<= (setq LstLng (length In_Lst)) NthPos) In_Lst )
( (zerop (setq LstLng (- LstLng (1+ NthPos))))
(reverse (cdr InRLst))
)
( T
(setq OldItm (nth NthPos In_Lst))
(while
(/=
NthPos
(length (setq InRLst (cdr (member OldItm InRLst))))
)
)
(while
(/=
LstLng
(length (setq In_Lst (cdr (member OldItm In_Lst))))
)
)
(append (reverse InRLst) In_Lst)
)
)
)
;;
;; keep on programmin'
;;; fine "Edita_Scale"
;;; --------------------------------------------------------------------------------- ;;;

;;; inizio SortListLeeMac
;;; --------------------------------------------------------------------------------- ;;;
;;; da: "www.theswamp.org/forum" SortList di Gile & LeeMac
;;; uso:
;;;(setq L_SCA (list "1:200" "1:1" "1:500" "1:5" "2:1" "Add" "1:20" "1:5000" ))
;;;(ArchSort L_SCA)
;;; --------------------------------------------------------------------------------- ;;;
;; ר ArchSort ר (Gile) ;;
;; ~ Sorts a list of strings by numerical ;;
;; values, then by Prefix/Suffix. ;;
;;; --------------------------------------------------------------------------------- ;;;
(defun ArchSort (lst / comparable comp x1 x2)
(defun comparable (e1 e2)
(or (and (numberp e1) (numberp e2))
(= 'STR (type e1) (type e2))
(not e1)
(not e2)))
(mapcar
(function
(lambda (x)
(nth x lst)))
(vl-sort-i (mapcar 'SplitStr lst)
(function
(lambda (x1 x2 / n1 n2 comp)
(while
(and (setq comp (comparable (setq n1 (car x1))
(setq n2 (car x2))))
(= n1 n2))
(setq x1 (cdr x1) x2 (cdr x2)))
(if comp (list str)
test (chr (car lst)))
(if (< 47 (car lst) 58)
(setq num T))
(while (setq lst (cdr lst))
(if num
(cond ((= 46 (car lst))
(if (and (cadr lst)
(setq tmp (strcat "0." (chr (cadr lst))))
(numberp (read tmp)))
(setq rslt (cons (read test) rslt) test tmp lst (cdr lst))
(setq rslt (cons (read test) rslt) test "." num nil)))
((< 47 (car lst) 58)
(setq test (strcat test (chr (car lst)))))
(T (setq rslt (cons (read test) rslt) test (chr (car lst)) num nil)))
(if (< 47 (car lst) 58)
(setq rslt (cons test rslt) test (chr (car lst)) num T)
(setq test (strcat test (chr (car lst)))))
)
)
(if num
(setq rslt (cons (read test) rslt))
(setq rslt (cons test rslt)))
(reverse rslt)
)
;;;---------------
;; ר toTop ר (Lee Mac) ;;
;; ~ Moves the nth item in a list to the ;;
;; 0th position. ;;
;;;uso: (setq L_SCA (toTop 6 L_SCA))
(defun toTop (i lst)
(cond ((zerop i) lst)
((append (list (nth i lst))
(remove_nth i lst))))
)
;;;---------------
;; ר Remove_nth ר (Lee Mac) ;;
;; ~ Removes the nth item in a list. ;;
;;; uso: (setq L_SCA (Remove_nth 0 L_SCA))
(defun Remove_nth (i lst / j)
(setq j -1)
(vl-remove-if
(function
(lambda (x)
(eq i (setq j (1+ j))))) lst)
)
;;;---------------
;;; ADJOIN - adds element to list, if not already in it
;;; uso: (ADjoin "1:251" L_SCA)
(defun ADjoin (item lst)
(cond ((member item lst) lst)
(t (cons item lst)))
)
;;;---------------
;;; Remove - remove element from list,
;;; uso: (Remove "1:251" L_SCA)
(defun Remove (expr lst)
(apply 'append (subst nil (list expr) (mapcar 'list lst)))
)

;;; fine SortListLeeMac

;;; inizio CFL_GestFinLay_3
;;; --------------------------------------------------------------------------------- ;;;
;;; Program from "Command Line" windows management
;;; --------------------------------------------------------------------------------- ;;;
(defun C:-GFL (/ SELEZio )
(initget "Block sbLock Lock WheelAll Congelayers Isolayers Scongelayers ?")
(setq SELEZ "Blocca")
(setq SELEZio (getkword (strcat " Windows - Block / sbLock / Wheel / BlockAll / Congelayers / Isolayers / Scongelayers /? ")))
(if (/= nil SELEZio)(setq SELECT SELEZio))
(C:GFL)
(princ)
) ;;fine GFL - gestione Finestre da "Riga Di Comando"

;;; --------------------------------------------------------------------------------- ;;;
;;; Programma gestione Finestre
;;; --------------------------------------------------------------------------------- ;;;
(defun C:GFL (/ lst SS thisdwg Ent Ent1 Ent-N i L lst N olderr Plock_VP SNA
TWA SS1 MsgRot lst2 #LA)
(setq olderr *error*
*error* attrerr
)

; Salva le variabili di sistema
(arcvar (list "cmdecho" "clayer" "osmode" "angbase" "aunits"))
(setvar "cmdecho" 0)
(command "_.undo" "_begin")
(cond
((= SELEZ "Scongelayers")
;;; ---------------------------------------------------------------------
;;; Funzione Scongela Tutti i Layer nella viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((> (getvar "cvport") 1)
(command "_.pspace")
)
)
(cond
((= (getvar "cvport") 1)
(princ "\n Choose the ViewPort to thaw All layers")
(setq SS (ssget ":E:S" '((0 . "Viewport"))))
(cond (( /= SS nil)
(setq SS (cdr (assoc 69 (entget (ssname SS 0)))))
(command "_.mspace")
(setvar "cvport" SS)
(command "_.vplayer" "_t" "*" "_c" "")
(command "_.pspace")
(prompt "\nAll layers have been thawed.")(princ)
)
)
)
)
)
)
;;; ---------------------------------------------------------------------
)
((= SELEZ "Isolayers")
;;; ---------------------------------------------------------------------
;;; Funzione Isola il/i Layer nella viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((= (getvar "cvport") 1)
(command "_.mspace"))
)
(cond
((> (getvar "cvport") 1)
(setq SS1 (ssget))
(if SS1
(progn
(setq Ent (entget (ssname SS1 0)))
(setq #LA (cdr (assoc 8 Ent)))
(setq L 1)
(setq N (sslength SS1)
)
(while ( (getvar "cvport") 1)
(setq SS1 (ssget))
(if SS1
(progn
(setq Ent (entget (ssname SS1 0)))
(setq #LA (cdr (assoc 8 Ent)))
(setq L 1)
(setq N (sslength SS1)
)
(while (ename ent))))
(vla-put-color (vlax-ename->vla-object (cdr ent1)) 256) ; color 256 (dalayer)
)
)
)
)
)
)
;;; (command "_.regenall")
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
;;; Select Viewports but not Layouts
;;; (ssget "x" '((0 . "VIEWPORT") (-4 . "/=") (69 . 1)))
(if (/= (setq SS (ssget "x" '((0 . "VIEWPORT") (-4 . "/=") (69 . 1))))nil)
(cond
((> (sslength SS) 1)(Alert (strcat "\nAll "(itoa (sslength SS))" virew port are locked.")))
((= (sslength SS) 1)(Alert (strcat "\nOnly one viewport has been locked.")))
)
(Alert (strcat "\nThere are no viewports in the drawing."))
)
)
((= SELEZ "sbLocca")
;;; ---------------------------------------------------------------------
;;; Funzione Sblocca la/e viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((/= (getvar "cvport") 1)
(command "_.pspace")
)
)
(cond
((= (getvar "cvport") 1)
;;;------------VPLock.lsp----------------------
;;; Purpose: Lock/Unlock Viewports by Selection
;;; Author : Herman Mayfarth
;;; Date : 1 July 2004
;;; Version: 1.0
;;; Copyright © 2004 Herman Mayfarth
;;; All rights reserved.
;;; Supplied "as is," and without warranty, express or implied.
;;; Permission granted to use & redistribute without fee,
;;; Provided file header including copyright notice remains intact.
;;;---------------------------------------------------------------
;;;unlocks viewports
;;; (defun C:VPUnlock ( / lst SS thisdwg)
;(vl-load-com)
(setq thisdwg (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark thisdwg)
(princ "\nSelect Viewport to Unlock: ")
(and
(setq SS (ssget '((0 . "VIEWPORT")(-4 . "/=") (69 . 1))))
;;;build a list of enames from the SS
(setq i 0)
(repeat (sslength SS)
(setq lst (cons (ssname SS i) lst))
(if (/= (assoc 340 (entget (ssname SS i))) nil)
(setq lst2 (cons (cdr (assoc 340 (entget (ssname SS i))))lst2))
)
(setq i (1+ i))
);repeat
;;;convert the enames to vla-objects
;;;and unlock the viewports
(mapcar '(lambda (x)
(vla-put-displaylocked (vlax-ename->vla-object x) :vlax-false)
(vla-put-color (vlax-ename->vla-object x) 170) ;;;setta colore 170 :blue
);lambda
lst
);mapcar
(mapcar '(lambda (x)
(vla-put-color (vlax-ename->vla-object x) 170) ;;;setta colore 256 :dalayer (40 orange)
);lambda
lst2
);mapcar
);and
(vla-endundomark thisdwg)
(princ)
(cond
((> (sslength SS) 1)(Alert (strcat "\n"(itoa (sslength SS))" viewports in the drawing has been unlocked.")))
((= (sslength SS) 1)(Alert (strcat "\nOne viewport in the drawing has been unlocked.")))
)
(princ)
);C:VPUnlock
)
)
)
)
((= SELEZ "Blocca")
;;; ---------------------------------------------------------------------
;;; Funzione Blocca la/e viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((/= (getvar "cvport") 1)
(command "_.pspace")
)
)
(cond
((= (getvar "cvport") 1)
;;;------------VPLock.lsp----------------------
;;; Purpose: Lock/Unlock Viewports by Selection
;;; Author : Herman Mayfarth
;;; Date : 1 July 2004
;;; Version: 1.0
;;; Copyright © 2004 Herman Mayfarth
;;; All rights reserved.
;;; Supplied "as is," and without warranty, express or implied.
;;; Permission granted to use & redistribute without fee,
;;; Provided file header including copyright notice remains intact.
;;;---------------------------------------------------------------
;;;locks viewports
;;; (defun C:VPLock ( / lst SS thisdwg)
;(vl-load-com)
(setq thisdwg (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark thisdwg)
(princ "\nSelect Viewports to Lock: ")
;(princ "\n Scegli le Finestre da Bloccare: ")
(and ;in lieu of (if SS ..) following sget
;;; (setq SS (ssget '((0 . "VIEWPORT"))))
(setq SS (ssget '((0 . "VIEWPORT")(-4 . "/=") (69 . 1))))
;;;build a list of enames from the SS
(setq i 0)
(repeat (sslength SS)
(setq lst (cons (ssname SS i) lst))
(if (/= (assoc 340 (entget (ssname SS i))) nil)
(setq lst2 (cons (cdr (assoc 340 (entget (ssname SS i))))lst2))
)
(setq i (1+ i))
);repeat
;;;convert the enames to vla-objects
;;;and lock the viewports
(mapcar '(lambda (x)
(vla-put-displaylocked (vlax-ename->vla-object x) :vlax-true)
(vla-put-color (vlax-ename->vla-object x) 256) ;;;setta colore 256 :dalayer (40 orange)
);lambda
lst
);mapcar
(mapcar '(lambda (x)
(vla-put-color (vlax-ename->vla-object x) 256) ;;;setta colore 256 :dalayer (40 orange)
);lambda
lst2
);mapcar
);and
(vla-endundomark thisdwg)
(princ)
(cond
((> (sslength SS) 1)(Alert (strcat "\n"(itoa (sslength SS))" viewports in the drawing has been locked.")))
((= (sslength SS) 1)(Alert (strcat "\nOne viewport in the drawing has been locked.")))
)
(princ)
);C:VPLock
)
)
)
)
((= SELEZ "Wheel")
;;; ---------------------------------------------------------------------
;;; Funzione Ruota la vista nella viewport
;;; (setvar "angbase" 0)
;;; (setvar "aunits" 0)
;;; ---------------------------------------------------------------------
(cond
((= SELEZ "Wheel")
(cond
((= (getvar "ctab") "Model")
(ALERT "\n ** Attension **\n\nYou are about to Rotate \ nThe Viewport !!! \n ")
)
)
(cond
((= (getvar "cvport") 1)
(command "_.mspace")
)
)
(princ "Choose points for horizontal alignment or write the angle of rotation: ")
;;; setq TWA (getangle))
(setq TWA (* (getangle) -1))
(setq SNA (* TWA -1))
;;; (setq TWA (angtos TWA (getvar "aunits")))
(setq TWA (angtos TWA (getvar "aunits") 4))
(cond
((/= (getvar "ctab") "Model")
;;; Unlock active Viewport
(if (equal :vlax-true
(vla-get-DisplayLocked
(vla-get-ActivePViewport
(vlax-get-property (vlax-get-acad-object) "ActiveDocument")
)
)
)
(progn
(vla-put-DisplayLocked
(vla-get-ActivePViewport
(vlax-get-property (vlax-get-acad-object) "ActiveDocument")):vlax-false)
(setq Plock_VP "BLO")
)
(setq Plock_VP "APE")
)
;;;end Unlock active Viewport
)
)
;;; (command "_.dview" "" "_tw" TWA "")
(command "_.dview" "_c" (getvar "vsmax") (getvar "vsmin") "" "_tw" TWA "")
(setvar "SNApang" SNA)
(cond
((/= (getvar "ctab") "Model")
;;; Lock active Viewport
(if (= Plock_VP "BLO")
(vla-put-DisplayLocked
(vla-get-ActivePViewport
(vlax-get-property (vlax-get-acad-object) "ActiveDocument")):vlax-true)
)
;;; End Lock active Viewport
)
)
(command "_.pspace")
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
(setq MsgRot (strcat "\n View rotation: " (rtos (atof TWA)2 2) (chr 176)))
(princ MsgRot)
)
)
)
((= SELEZ "?")
;;; ---------------------------------------------------------------------
;;; Guida
;;; ---------------------------------------------------------------------
(InfoGFL)
;;; ---------------------------------------------------------------------
)
) ;;fine cond
(princ)
(command "_.undo" "_end")
;; Ripristina le variabili di sistema al valore iniziale - Tee Square Graphics
(resvar)
(princ)
) ;;fine GFL - gestione Finestre
;;; fine CFL_GestFinLay_3

;;; inizio CFL_Info_6
;;; --------------------------------------------------------------------------------- ;;;
;;; from info YAD's 'INFO.LSP'
;;; https://www.theswamp.org/index.php?topic=41239.0;nowap
;;; --------------------------------------------------------------------------------- ;;;
(defun c:FLinfo (/ name$ acaddoc olderr oldvar ss loop
gr pt ent oldent val oldlayer oldTxtStyle
oldsnap newstyle newlayer LayFIN LayAnnFIN StyTxt)

(setvar "cmdecho" 0)
;;; nomi layer stili
(setq LayFIN "cfCornice")
(setq LayAnnFIN "cfEtichetta")
;;; nomi stili
(setq StyTxt "cfFinlay")

(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
((and (/= (getvar "ctab") "Model") (= (length (vports)) 2))
(setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark acaddoc)
(prompt "\n** Info CreaFinLay ** \n ** Esc/Invio per uscire **")
(setq olderr *error*
*error* myerr
oldvar (list (list "osmode" (getvar "osmode"))
(list "fillmode" (getvar "fillmode"))
)
ss (ssadd)
loop T
)

(setq oldsnap (getvar "osmode" ))
(command "_.undo" "_begin")

(setvar "osmode" 0)
(setvar "fillmode" 1)

(if (not (tblsearch "style" StyTxt)) ;;FinLay Finestre
(progn
(setq newstyle (vla-add (vla-get-textstyles acaddoc) StyTxt))
(vla-put-fontfile newstyle (strcat (getenv "Windir") "\\fonts\\arial.ttf"))

)
)
(if (not (tblsearch "layer" LayFIN)) ;;FinLay-Finestra Finestre
(progn
(setq newlayer LayFIN)
(setq newlayer (vla-add (vla-get-layers acaddoc) newlayer))
;;; (vla-put-LayerOn newlayer 1) ;;; ; set the layer on
(vla-put-color newlayer 40)
(vla-put-plottable newlayer :vlax-false)
;;; (vla-put-activeLayer acaddoc newlayer) ;;; ; set active layer
)
)
(if (not (tblsearch "layer" LayAnnFIN));;FinLay-Etichetta Fin-Sc Txt
(progn
(setq newlayer LayAnnFIN)
(setq newlayer (vla-add (vla-get-layers acaddoc) newlayer))
;;; (vla-put-LayerOn newlayer 1) ;;; ; set the layer on
(vla-put-color newlayer 1)
;;; (vla-put-activeLayer acaddoc newlayer) ;;; ; set active layer
)
)

(while loop
(setq gr (grread T 8))
(cond
((or (= (car gr) 12) (= (car gr) 5))
(setq pt (cadr gr))
(setq ent (nentselp pt))

(setq ent (if (and ent (= (type (last (last ent))) 'ename))
(last (last ent))
(car ent)
)
)
(if ent
(if (not (or (equal ent oldent) (ssmemb ent ss)))
(progn
(del_ss ss)
;;;----------*
(if (and
(or (= (dxf ent 0) "CIRCLE")
(= (dxf ent 0) "ELLIPSE")
(= (dxf ent 0) "LWPOLYLINE")
)
(dxf ent 330)
(= (dxf (dxf ent 330) 0) "VIEWPORT")
)
(setq ent (dxf ent 330))
)
;;;----------*
(redraw ent 3)
(dis_info ent)
(setq oldent ent)
)
)
(progn
(del_ss ss)
(setq oldent nil
ss (ssadd)
)
)
)
)
((= (car gr) 3)
(if oldent
;;; (if (= (getvar "cmdnames") "")
(if (and (= (getvar "cmdnames") "") (= name$ "VIEWPORT") (/= XDVALUE nil))
(progn
(sssetfirst nil (ssadd oldent))
;;; (vl-cmdf "_.properties")
(progn
(del_ss ss)
(setq oldent nil
ss (ssadd)
)
)
(add_Mtext)
(prompt "\n ** Esc / Enter to exit **")
)
(prompt "\n ** Esc / Enter to exit **")
)
)
)
(T (setq loop nil))
)
)
(del_ss ss)
(if (or (= (car gr) 12) (= (car gr) 25))
(sssetfirst)
)
(setq *error* olderr)
(foreach itm oldvar (setvar (car itm) (cadr itm)))
(vla-endundomark acaddoc)
(vlax-release-object acaddoc)
))
(princ)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun myerr (msg)
(del_ss ss)
(setq *error* olderr)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun dxf (ent n)
(if (= (type ent) 'ename)
(setq ent (entget ent))
)
(cdr (assoc n ent))
)
;;; --------------------------------------------------------------------------------- ;;;
(defun del_ss (ss / n)
(setq n -1)
(repeat (sslength ss)
(entdel (ssname ss (setq n (1+ n))))
)
(if oldent
(redraw oldent 4)
)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun add_solid (p1 p2 p3 p4)
(entmakex (list (cons 0 "SOLID")
(cons 100 "AcDbEntity")
(cons 62 40)
(cons 100 "AcDbTrace")
(cons 10 p1)
(cons 11 p2)
(cons 12 p3)
(cons 13 p4)
(cons 210 (trans (getvar "viewdir") 1 0))
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun add_text (pt h txt)
(entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 62 170)
(cons 100 "AcDbText")
(cons 10 pt)
(cons 40 h)
(cons 1 txt)
(cons 50 0.0)
(cons 7 StyTxt)
(cons 72 0)
(cons 73 0)
(cons 210 (trans (getvar "viewdir") 1 0))
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun add_Mtext (/ EntMT oldRigen)
(entmake (list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 7 StyTxt) ;;; stile testo
(cons 8 LayAnnFIN) ;;; layer
(cons 71 5) ;;; Punto di collegamento - mezzo centro
(cons 40 5.0) ;;; $a ;;; Altezza del testo nominale (iniziale)
(cons 90 3) ;;; Maschera di sfondo con colore sfondo disegno
(cons 45 1.2) ;;; Fattore Offset Bordo
;;; $b
(cons 1
(strcat "{\\L\\P\\l\\H0.7x;"
(vlax-variant-value (caddr (vlax-safearray->list XDVALUE)))
"}"
)
)
;;; $c
(cons 10 pt)
)
)

;;; presenta il testo in modo editazione
(setq EntMT (entget (entlast)))
(setq oldRigen (getvar "regenmode"))
(setvar "regenmode" 0)
(vl-cmdf "_.Zoom"
"_c"
(cdr (assoc 10 EntMT))
(* (cdr (assoc 40 EntMT)) 30)
)
(vl-cmdf "_.ddedit" (cdr (assoc -1 EntMT)) "")
(vl-cmdf "_.Zoom" "_p")
(setvar "regenmode" oldRigen)
(princ "\n")
)
;;; --------------------------------------------------------------------------------- ;;;
(defun dis_info (ent / obj lst h high width ang n)
(setq obj (vlax-ename->vla-object ent)
name$ (dxf ent 0)
)

(vla-getXData Obj "CreaFinLay" 'XDTYPE 'XDVALUE) ;;creaFinLayINFO
(if (/= XDVALUE nil)
(progn
(vla-getXData Obj "CreaFinLay" 'XDTYPE 'XDVALUE)
(mapcar
'(lambda (X Y)
(cons X Y)
)
(vlax-safearray->list XDTYPE)
(vlax-safearray->list XDVALUE)
)
(setq lst (list
(strcat " *** Info "
(vlax-variant-value (car (vlax-safearray->list XDVALUE)))
" *** "
)
(strcat
(vlax-variant-value (cadr (vlax-safearray->list XDVALUE)))
)
(strcat
(vlax-variant-value (caddr (vlax-safearray->list XDVALUE)))
)
)
)
)
(if (= name$ "VIEWPORT")
(setq lst (list
(strcat "** missing information **")
(strcat " not created with CreaFinLay "))
)
(setq lst (list ""))
)
)

(setq lst (append (list (car lst)) (cdr lst))
ss (ssadd)
h (/ (getvar "viewsize") 60)
high (* 1.80 h (length lst))
width (* 0.70 h (apply 'max (mapcar 'strlen lst)))
ang (angle (trans (getvar "viewctr") 1 2) (trans pt 1 2))
pt (trans (mapcar '+ pt (getvar "target")) 1 2)
ang (cond
((>= (/ pi 2) ang 0)
(list (list (- (car pt) width) (- (cadr pt) high) (caddr pt))
(list (- (car pt) width) (cadr pt) (caddr pt))
)
)
((>= pi ang (/ pi 2))
(list (list (+ (car pt) width) (- (cadr pt) high) (caddr pt))
pt
)
)
((>= (+ pi (/ pi 2)) ang pi)
(list (list (+ (car pt) width) (+ (cadr pt) high) (caddr pt))
(list (car pt) (+ (cadr pt) high) (caddr pt))
)
)
((>= (* 2 pi) ang (+ pi (/ pi 2)))
(list (list (- (car pt) width) (+ (cadr pt) high) (caddr pt))
(list (- (car pt) width) (+ (cadr pt) high) (caddr pt))
)
)
)
)
(ssadd (add_solid pt
(list (caar ang) (cadr pt) (caddr pt))
(list (car pt) (cadar ang) (caddr pt))
(car ang)
)
ss
)
(setq pt (cadr ang)
pt (list (+ (car pt) (* 0.5 h)) (cadr pt) (caddr pt))
)
(setq n -1)
(repeat (length lst)
(ssadd (add_text (setq pt (list (car pt) (- (cadr pt) (* 1.6 h)) (caddr pt)))
h
(nth (setq n (1+ n)) lst)
)
ss
)
)
)
;;; fine CFL_Info_6

;;; --------------------------------------------------------------------------------- ;;;
;;; messaggi guida
;;; --------------------------------------------------------------------------------- ;;;
(defun InfoCreaFinLay (/)
(msgbox
"Help - Create Layout ViewPorts"
32
"
The Window is automatically locked to prevent an accidental
zoom change in the window itself and then scale.
With the '' Annotate Scale '' option selected, ask where to place the
text with the value of the Scala. By editing it you can add the
description of the object represented (eg Plan / Prospectus / etc).
With the '' Create SOLO Dim Style '' option, a dimension style is created
associated with the scale and design units chosen and becomes the style of
current quota; the texts of the dimensions have a height corresponding to
2.5 mm (*) in the Paper Space.

Angelo Stocco - April 2016

"
)
)
(princ);_end
;;; --------------------------------------------------------------------------------- ;;;
(defun InfoGFL (/)
(msgbox
"Guida - Gestione Finestre di Layout"
32
"
''FLINFO'' Mostra infornazioni su unitא e scala della Finestra al
passaggio del puntatore; cliccandoci con il tasto sx del
mouse, inserisce l'annotazione della scala e apre l'editor
per completare la descrizione.

''-GFL'' opzioni:
> 'BLOCCA' la Visualizzazione della/e Finestra/e selezionata/e
ed applica alla finestra il colore ''DaLayer''.
> 'SBLOCCA' la Visualizzazione della/e Finestra/e selezionata/e
ed applica alla finestra il colore ''170'' per avvisare della
visualizzazione sbloccata.
> 'BLOCCATUTTE' la Visualizzazione di Tutte le Finestre del
disegno corrente ed applica alle finestre il colore ''DaLayer''.
> 'RUOTA' la Visualizzazione nella Finestra. Richiede la selezione
di due punti da assegnare come nuovo allineamento
orizzotale oppure digitazione di un angolo.
(0 ripristina l'angolo originale).
> 'CONGELA' i Layers selezionati nella Finestra.
> 'ISOLA' i Layers selezionati nella Finestra congelando gli altri.
> 'SCONGELA' Tutti i Layers nella Finestra selezionata.
> '?' Questa guida.

Angelo Stocco - Aprile 2016
"
)
)
(princ);_end
;;; --------------------------------------------------------------------------------- ;;;
;;; box messaggio tipo VB - WScript.Shell
;;; http://www.theswamp.org/index.php?topic=29537.0
;;; MsgBox (Patrick_35)
;;; --------------------------------------------------------------------------------- ;;;
;;;
;;; Val buttons
;;; 0 vlax-vbOKOnly
;;; 1 vlax-vbOKCancel
;;; 2 vlax-vbAbortRetryIgnore
;;; 3 vlax-vbYesNoCancel
;;; 4 vlax-vbYesNo
;;; 5 vlax-vbRetryCancel
;;; 16 vlax-vbKatakana
;;; 32 vlax-vbQuestion
;;; 48 vlax-vbExclamation
;;; 64 vlax-vbInformation
;;;
;;; Val return
;;; 1 OK
;;; 2 Cancel
;;; 3 Abort
;;; 4 Retry
;;; 5 Ignor
;;; 6 Yes
;;; 7 No

(defun MsgBox (title buttons message / return WshShell)
(setq WshShell (vlax-create-object "WScript.Shell"))
(setq return (vlax-invoke
WshShell
'Popup
message
0 ;time
title
(itoa buttons)
)
)
(vlax-release-object WshShell)
return
);_end MsgBox
;;; --------------------------------------------------------------------------------- ;;;

(vl-load-com)
(princ
(strcat
"\n\\U+00AB ViewPort Creator - CFL.lsp - April 2016 \\U+00BB"
"\n\\U+00AB comandi: \"CreaFinLay\" o \"CFL\", \"-GFL\", \"FLINFO\". \\U+00BB"
)
)

(defun igalvp (/ vpl vplyes l0 ln layers cp cl cs ofs vpc1 vpc2 vpxd vpyd vpc svpc ssvp ssvp1 sf lpno vpno ssnum vpent nvpc1 nvpc2 nvpc1x nvpc1y nvpc2x nvpc2y)
; Creates layout of Paper Space viewports of specified 2D orthagonal views from Model Space
; Used when all 2D design is done in Model Space at full scale and all dimensioning is done in Paper Space as associated scale
; Start command from destination layout tab
; Program will switch to Model Space for selection of desired objects
; Program will return to layout tab for creation of viewport frames
; First a single viewport is made that includes all relevant views of desired part at the desired zoom level
; The single viewport is copied over itself the number of desired separate views
; Then the overlaying viewports are individually clipped to the edges of the separate views
; The separate views will maintain their original orientation and alignment
; The separate views can be rectangular by specifying opposite corners or circular by specifying a center and radius
; Afterwards move the individual views orthogonally, if needed, to allow space for dimensions
(setvar "cmdecho" 0) ; Turn off command line echoing
(setvar "tilemode" 0)
(setq cp (getvar "ctab")) ; Store current tab name
(setq cl (getvar "clayer")) ; Store current layer name
(setq cs (getvar "osmode")) ; Store current osnap mode
(setq vpl "Viewport") ; ==>> Assume using Viewport layer for viewport frames, change code value here if needed <> Set viewport border offset from actual detail, change code value here if needed <<==
(setvar "osmode" 16416) ; Turn osnap off
(if (/= cp "Model") ; Must be started from a layout tab to establish destination, quit quietly if on Model tab
(progn
(princ "\n") ; Clean up command line
(setq vplyes 0) ; Assume viewport doesn't exist
(setq l0 (tblnext "LAYER" 1)) ; Get past 0 layer in layer list
(while (setq layers (tblnext "LAYER")) ; Loop through layer list collection
(setq ln (cdr (assoc 2 layers))) ; Extract layer name from list
(if (= (strcase ln) (strcase vpl)) (setq vplyes 1)) ; Check if viewport layer exists
)
(if (= vplyes 0) (command "layer" "NEW" vpl "COLOR" "1" vpl "")) ; Make viewport layer and assign color to red if doesn't exist
(setvar "clayer" vpl) ; Change to viewport layer
(command "layer" "ON" (strcat "0," vpl) "UNLOCK" (strcat "0," vpl) "") ; Turn on and unlock viewport and 0 layer
(command "zoom" "e") ; View entire layout tab
(setvar "ctab" "Model") ; Activate Model tab
; (command "zoom" "e") ; View entire Model Space area
(setq vpc1 (getpoint "\nSpecify first corner of model space window area: ")) ; Just pick rough area including all relavent details, will fine-tune border area later in Paper Space
(if vpc1 ; Quietly quit if no point specified
(progn
(setq vpc2 (getcorner vpc1 "\nSpecify opposite corner of model space window area: ")) ; Window rectangle can be designated in any direction
(if vpc2 ; Quietly quit if no point specified
(progn
(princ "\n") ; Clean up command line
;(setvar "ctab" cp) ; Return to layout tab program was started from
(setvar "CTAB" Lay)
(command "pspace") ; Switch to Paper Space of layout tab
(setq svpc (getpoint "\nSpecify destination of paper space viewport center: ")) ; Can't change layout tabs manually here
(if svpc ; Quietly quit if no point specified
(progn
;(setq sf (getreal "\nViewport zoom scale factor : ")) ; Default to full-scale if no value is inputted

(setq sf (distof FattZoom))

(if (= sf nil) (setq sf 1.0) (setq sf (abs sf))) ; Make sure scale factor is positive number
(setq vpxd (* sf (abs (- (car vpc2) (car vpc1))))) ; Determine horizontal length of selected window
(setq vpyd (* sf (abs (- (cadr vpc2) (cadr vpc1))))) ; Determine vertical height of selected window
(setq vpc (list (/ (+ (car vpc1) (car vpc2)) 2.0) (/ (+ (cadr vpc1) (cadr vpc2)) 2.0) 0.0)) ; Determine center point of selected model window
(command "mview" (list (- (car svpc) (/ vpxd 2.0)) (- (cadr svpc) (/ vpyd 2.0))) (strcat "@" (rtos vpxd) "," (rtos vpyd))) ; Create Paper Space viewport
(setq ssvp (ssget "L")) ; Start selection set with last viewport frame
(setq ssvp1 (ssget "L")) ; Another copy of viewport frame selection set
(command "mspace") ; Open viewport window to Model Space
(command "ucsicon" "ON") ; Turn on UCS icon for viewport
(command "ucs" "WORLD") ; Reset UCS to WCS
(command "zoom" "C" vpc (rtos vpyd)) ; Center view of viewport window using determined point

;(command "_.zoom" "_c" Ptmed ScXP)

(command "zoom" "SCALE" ScXP "XP") ; Set zoom scale of viewport window
(command "vports" "LOCK" "ON" ssvp "") ; Lock scale and position of model in viewport
(command "pspace") ; Close viewport window
(command "zoom" (list (- (car svpc) (/ vpxd 2.0)) (- (cadr svpc) (/ vpyd 2.0))) (strcat "@" (rtos vpxd) "," (rtos vpyd))) ; Zoom in on just created viewport extremes
(command "zoom" "0.95X") ; Back zoom off slightly to see edges clearly
(setq lpno 2) ; Loop counter for making separate viewports
(setq vpno (getint "\nNumber of separate viewports to make from this viewport : ")) ; Will divide single viewport into separate viewports for othagonal views of 2D part
(if (>= vpno 2) ; Proceed to copy current viewport if 2 or more separate viewports desired
(progn
(while (<= lpno vpno) ; Check if viewport loop counter less than number of viewports desired
(command "copy" ssvp "" "0,0" "@0,0") ; Make copy of new viewport laying exactly on top of first viewport
(setq lpno (1+ lpno)) ; Increment viewport loop counter
(ssadd (entlast) ssvp1) ; Add viewport copy to selection set
)
)
)
(setq ssnum 0) ; Loop counter for fine-tuning separate viewports
(while (= vpno 2) ; Check for multiple viewports
(setq clt (strcat " #" (rtos (+ ssnum 1) 2 0))) ; Make command prompt string if using multiple viewports
(setq clt "") ; Make command prompt string if using single viewport
)
(initget 128) ; Enable string responses from point prompt
(setvar "osmode" 32)
(setq nvpc1 (getpoint (strcat "\nSpecify first corner of viewport" clt " window area or [Center point of circle]: "))) ; Pick actual part corner, program will apply offset
(if nvpc1 ; Will repeat asking for first corner if none specified
(progn
(if (= 'STR (type nvpc1)) ; Check if string was inputted instead of corner point
(progn
(if (= "C" (strcase (substr nvpc1 1 1))) ; Check if asking for circular viewport area
(progn
(setq nvpc1 (getpoint (strcat "\nSpecify center of viewport" clt " window area: "))) ; Pick center of separate circular viewport window
(if nvpc1 ; Will return to asking for first corner if center not specified
(progn
(setvar "osmode" 0) ; Turn osnap off
(princ (strcat "\nSpecify radius of viewport" clt " window area: ")) ; Make command prompt for circle viewport
(command "circle" nvpc1 pause) ; Make circle to clip existing viewport
(setvar "osmode" 2559) ; Turn osnap on
(setq ssvp (ssget "L")) ; Select last circle
(command "vpclip" vpent ssvp) ; Clip existing viewport to circle
(setq ssnum (1+ ssnum)) ; Increment fine-tuned viewport loop counter
)
)
)
)
)
(progn
(setq nvpc2 (getcorner nvpc1 (strcat "\nSpecify opposite corner of viewport" clt " window area: "))) ; Window rectangle can be designated in any direction, pick actual part corner, program will apply offset
(if nvpc2 ; Will repeat asking for first corner if none specified
(progn
(setq nvpc1x (car nvpc1)) ; Find X portion of first corner
(setq nvpc1y (cadr nvpc1)) ; Find Y portion of first corner
(setq nvpc2x (car nvpc2)) ; Find X portion of second corner
(setq nvpc2y (cadr nvpc2)) ; Find Y portion of second corner
(if (> nvpc2x nvpc1x) ; Determine horizontal direction of viewport window rectangle
(progn
(setq nvpc2x (+ nvpc2x ofs)) ; Add horizontal offset to right of specified left-to-right window rectangle
(setq nvpc1x (- nvpc1x ofs)) ; Add horizontal offset to left of specified left-to-right window rectangle
)
(progn
(setq nvpc2x (- nvpc2x ofs)) ; Add horizontal offset to left of specified right-to-left window rectangle
(setq nvpc1x (+ nvpc1x ofs)) ; Add horizontal offset to right of specified right-to-left window rectangle
)
)
(if (> nvpc2y nvpc1y) ; Determine vertical direction of viewport window rectangle
(progn
(setq nvpc2y (+ nvpc2y ofs)) ; Add vertical offset to top of specified lower-to-upper window rectangle
(setq nvpc1y (- nvpc1y ofs)) ; Add vertical offset to bottom of specified lower-to-upper window rectangle
)
(progn
(setq nvpc2y (- nvpc2y ofs)) ; Add vertical offset to bottom of specified upper-to-lower window rectangle
(setq nvpc1y (+ nvpc1y ofs)) ; Add vertical offset to top of specified upper-to-lower window rectangle
)
)
(setvar "osmode" 0) ; Turn osnap off
(command "rectang" (list nvpc1x nvpc1y) (list nvpc2x nvpc2y)) ; Make rectangle with offset to clip existing viewport
(setvar "osmode" 2559) ; Turn osnap on
(setq ssvp (ssget "L")) ; Select last rectange
(command "vpclip" vpent ssvp) ; Clip existing viewport to rectangle
(command "vpclip" ssvp "d" ) ; Convert Polygonal Vport to Rectangular
(setq ssnum (1+ ssnum)) ; Increment fine-tuned viewport loop counter
)
)
)
)
)
)
)
)
)
)
)
)
)
)
(princ "\nThis command must be started from a layout sheet!") ; Need to start on a layout tab so program knows where to create the new viewports
)
(setvar "ctab" cp) ; Reset to stored tab name
(setvar "clayer" cl) ; Reset to stored layer name
(setvar "osmode" cs) ; Reset to stored osnap mode
(setvar "cmdecho" 1) ; Turn on command line echoing
(princ) ; Clean up and exit
)

(princ)
(c:cfl)

Draw “background” wide polylines under polylines selected by user


;;; Draw "background" wide polylines under polylines selected by user
;;; Based on routine created by BIGAL saved from: http://www.cadtutor.net/forum/showthread.php?98213-Copy-text-into-same-place-but-in-different-layer
;;; Combined and Deeply modified by Igal Averbuh 2018 (added option to copy any kind of objects and select layer to copy to)
;;; Helped by dbhunia https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-make-selection-set/m-p/8404026#M377088
;;; Finaly modified by CADffm

;; Polyline Width - Lee Mac
;; Applies a given constant width to all segments in a selection of polylines.

(defun c:pw ( / *error* idx sel wid )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel (LM:ssget "\nSelect polylines: " '("_:L" ((0 . "LWPOLYLINE,POLYLINE")))))

;(setq sel (ssget "L" (list '(0 . "LWPOLYLINE,POLYLINE"))))

(progn
(initget 4)
(setq wid 1.0) ;here to set wigth op backgroung polyline
;(setq wid (getdist "\nEnter New Width: "))
(repeat (setq idx (sslength sel))
(vla-put-constantwidth (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) wid)
)
)
)
(*error* nil)
(princ)
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)

(defun c:ccl (/ ss)
(setvar 'CMDECHO 0)
(princ "\n\nSelect Objects for BACKGROUND layer.")
(if (setq ss (ssget "_:L"))
(progn
(command
"_.LAYER" "_new" "0-BACKGROUND" "_on" "0-BACKGROUND" "_thaw" "0-BACKGROUND" ""
"_.copy" ss "" "_non" "0,0" "_non" "0,0"
"_.chprop" "_p" "" "_layer" "0-BACKGROUND" ""
)
(sssetfirst nil ss)
)
(princ "\nNothing selected, canceled.")
)
(princ)
)

(defun c:bg ( / )
(setq oldclayer (getvar "clayer"))
(command "-layer" "m" "0-BACKGROUND" "C" "42" "0-BACKGROUND" "")
(c:ccl)
(c:pw)
(command "draworder" "P" "" "b")
(setvar "clayer" oldclayer)
)

Create Clipped Viewport over other viewports via closed boundary polyline

Create Clipped Viewport over other viewports via closed boundary polyline

like it shown on picture

Capture.JPG


;; Create Clipped Viewport over other viewports via closed boundary polyline
;; Lisp can ask internal point to create closed polyline and ask which viewport need to clip

(defun c:VBC ( / enl)
(setq enl (entlast))
(setvar 'HPISLANDDETECTIONMODE 1)
(command-s "_.BOUNDARY")
(if (not (equal enl (entlast)))
(command "_.DRAWORDER" "_L" "" "_Back"
"_.VPCLIP" PAUSE "_L"))
(princ)
)
(c:vbc)

Angelo Stocco ViewPort Creator – CFL (English version)


;;; --------------------------------------------------------------------------------- ;;;
;;; Create Layout Windows & Layout Manager ;;;
;;; -------------------------------------------------- ------------------------ ;;;
;;; Requires "ai_utils.lsp" ;;;
;;; ;;;
;;; It derives from the similar program: "Mishaeli ViewPort Creator" by Isak Mishaeli ;;;
;;; ;;;
;;; In the various updates I have used functions found in the forums, some ;;;
;;; used in full, others with appropriate modifications. ;;;
;;; A dutiful delivery to those who have simplified my work: ;;;
;;; Bill Kramer, Tee Square Graphics, Gilles Chanteau, Marc'Antonio Alessi, ;;;
;;; Lee McDonnell, kojacek, Tharwat, Piercey-Jason, Richard Willis, etc. ;;;
;;; The function headings contain the names of the respective authors. ;;;
;;; -------------------------------------------------------------------------- ;;;
;;; Commands: ;;;
;;; ;;;
;;; CreaFinLay: Create Layout Windows (graphic dialog - DCL) ;;;
;;; CFL: Abbreviation of CreaFinLay ;;;
;;; ;;;
;;; -GFL: Management of Layot Windows (command line options) ;;;
;;; - Window Options: Lock, sbLock, Rotate, LockAll ;;;
;;; - Windows Layer Options: Congelayers, Isolayers, Scongelayers ;;;
;;; -? Guide ;;;
;;; FLINFO: Information Layout window and restore annotation scale ;;;
;;; - when the pointer passes over the frame, it shows a scale ;;;;;
;;; unit used; ;;;
;;; - clicking on it with the left mouse button, enter the annotation ;;;
;;; of the ladder and opens the editor to complete the description ;;;
;;; ;;;
;;; -------------------------------------------------- ------------------------ ;;;
;;; Angelo Stocco - April 2016 ;;;
;;; -------------------------------------------------- ------------------------ ;;;
;;; 2007 October - 1st edition AS ;;;
;;; Revisions: ;;;
;;; 2016
;;; "Dirty" translated to English by Igal Averbuh 2018 ;;;
;;; because It's better than nothing ;;;
;;; ;;;
;;; --------------------------------------------------------------------------------- ;;;
(defun c:CFL (/) (c:CreaFinLay))
(defun c:CreaFinLay (/ Convert Dcl_Id% result Ent Entname
EntNamePLay EntNamePModel FattZoom fileread Index
IndexC L_LAY L_SCA Lay LayAnnFIN LayDim
LayFin Li_DCA aline ListaV ListaVX ListaVY
minX minY Appl maxX maxY n
nrVertici oldlayer oldTxtStyle p pC Ptmin
Ptmax PtCen Sca ScXP ScXPDCL ssvp
StyDim StyDTxt StyTxt TE ValSca WriteScala
AppNum Wc0 Pt2 PtRagMag Larg_SC PC_SC
Wc1 Wc2 EntVP $a $b $c
EntNamePLayVP Lst-Serie oldsnap CreDimScala Alt_SC
DataOggi OraOggi NListaV Wc1M Wc2M pcName
pcCode filename ListaDS dimstyle_names DS_nlst
StQuo RigaCommento0 RigaCommento1 UnitXD
PrefStyDim NumVP globalList globalListPick RES
BT Dimstyle NewDim OldStyDim StyDimARCHI StyDimMECCA
dimstyle_names StyDimSTAND)

(setq olderr *error*
*error* attrerrCfl
)

;;; --------------------------------------------------------------------------------- ;;;
;;; from Autodesk FIND.LSP
;;; Check to see if AI_UTILS is loaded, If not, try to find it, and then try to load it.
;;; If it can't be found or it can't be loaded, then abort the loading of this file
;;; immediately, preserving the (autoload) stub function.
;;; --------------------------------------------------------------------------------- ;;;
(cond
((and ai_dcl (listp ai_dcl))) ; it's already loaded.
((not (findfile "ai_utils.lsp")) ; find it
(ai_abort "CreaFinLay" "file AI_UTILS.LSP. not found\n Check the support folder."))

((eq "failed" (load "ai_utils" "failed")) ; load it
(ai_abort "CreaFinLay" "Unable to load the file AI_UTILS.LSP"))
)

(if (not (ai_acadapp)) ; defined in AI_UTILS.LSP
(ai_abort "CreaFinLay" nil) ; a Nil supresses
) ; ai_abort's alert box dialog.

;;; --------------------------------------------------------------------------------- ;;;
(setq Appl "CreaFinLay")
(setq RigaCommento0 "CreaFinLay v6.0")
(setq RigaCommento1 "AS - 15.04.2016")

; Salva le variabili di sistema
(arcvar (list "cmdecho" "clayer" "osmode" "regenmode" ))

(setvar "cmdecho" 0)

; plinetype 2: crea e converte in polilinee ottimizzate "LWPOLYLINE"
(setvar "plinetype" 2)

(setq OldStyDim (getvar "Dimstyle"))
(setq oldlayer (getvar "clayer"))
(setq oldTxtStyle (getvar "textstyle"))
(setq oldsnap (getvar "osmode" ))
(command "_.undo" "_begin")
(SETQ VerCAD (substr (GETVAR "ACADVER") 1 4))

(cond
((= Lay_nlst nil)
(setq Lay_nlst (vl-position (getvar "CTAB") (mapcar 'vla-get-Name (getLays))))
)
((/= Lay_nlst (vl-position (getvar "CTAB") (mapcar 'vla-get-Name (getLays))) nil)
(setq Lay_nlst (vl-position (getvar "CTAB") (mapcar 'vla-get-Name (getLays))))
)
)
(if (/= "CTAB" "Model")
(setvar "CTAB" "Model")
)
(CreaLayStyTXT)

;;; --------------------------------------------------------------------------------- ;;;
;;;Initialation_Code
(defun DCL_inizio_gestione(/)
(LogoCFL "vectors")
(ListaLay)
(ListaDimStili)
(LeggiFileScale)
(m_cm_mm)
(ScalaFinLay)
(FormaFin)
(mode_tile "$LAY" 2) ; attiva Focus selezione layout
(set_tile "$CSD" "0")
(setq CreDimScala "0")
(mode_tile "$rc0" 1)
(set_tile "$rc0" RigaCommento0)
(mode_tile "$rc1" 1)
(set_tile "$rc1" RigaCommento1)
(set_tile "$WS" "1")
(setq WriteScala "1")
(set_tile "$ScXP" (strcat "Zoom "ScXP))
(mode_tile "$DST" 1)
(princ)
);End of Initial Function

;;;Start Set function
(defun DCL_imposta_dati(/)
(action_tile "$M" "(setq Convert 1000.0 Unit$ \"m\")(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$CM" "(setq Convert 10.0 Unit$ \"cm\")(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$MM" "(setq Convert 1.0 Unit$ \"mm\")(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$LSCA" "(setq Sca_nlst (atoi $value))(ScalaFinLay)(set_tile \"$ScXP\" (strcat \"Zoom \"ScXP))")
(action_tile "$CSD" "(StiliDIM)(ListaDimStili)(setq CreDimScala (get_tile \"$CSD\"))(if (= CreDimScala \"1\" )(congela)(scongela))")
(action_tile "$WS" "(setq WriteScala (get_tile \"$WS\"))")
(action_tile "$RET" "(setq Forma$ \"RET\")")
(action_tile "$CER" "(setq Forma$ \"CER\")")
(action_tile "$ELI" "(setq Forma$ \"ELI\")")
(action_tile "$POL" "(setq Forma$ \"POL\")")
(action_tile "$LAY" "(setq Lay_nlst (atoi $value))")
(action_tile "$DST" "(setq DS_nlst (atoi $value))")
(action_tile "$EdSca" "(EditaScale)")
(princ)
);End of Set function

;;;Start Get function
(defun DCL_rileva_dati(/)
(setq Lay_nlst (atoi (get_tile "$LAY")))
(setq Lay (nth Lay_nlst L_LAY))
(setq DS_nlst (atoi (get_tile "$DST")))
(setq StQuo (nth DS_nlst ListaDS))
(ScalaFinLay)
(m_cm_mm)
(FormaFin)
(princ)
);End of Get function

(create_dcl "viewport-creator1.dcl")
(if (setq Dcl_Id% (load_dialog (strcat (getvar "roamablerootprefix")"viewport-creator1.dcl")))
(if (not (new_dialog "CreaFinLayout" Dcl_Id%)) (exit)
(progn
(setq result nil)
(DCL_inizio_gestione)
(DCL_imposta_dati)
(action_tile "help" "(InfoCreaFinLay))")
(action_tile "cancel" "(done_dialog)(exit)")
(action_tile "accept" "(DCL_rileva_dati)(done_dialog)(setq result T)")
(start_dialog)
(unload_dialog Dcl_Id%)
result
)
)
)

(if (/= CreDimScala "1")
(progn
(cond
((= Forma$ "RET")(VportRET)(XDAdd))
((= Forma$ "CER")(VportCER)(XDAdd))
((= Forma$ "ELI")(VportELI)(XDAdd))
((= Forma$ "POL")(VportPOL)(XDAdd))
)
(if (= WriteScala "1")(ScriveScala_TM))
);progn
);if

(cond
((= CreDimScala "1")
(command "_.-dimstyle" "_restore" StQuo)
(CreaStyDim)
(_SetDimStyleCurrent NewDim)
; la creazione delle quote imposta anche l'altezza dei testi a 2.5 mm
(setvar "textsize" (/ 2.5 (distof FattZoom 2)))
)
)

(command "_.undo" "_end")

; Riporta le variabili di sistema al valore iniziale
(resvar)
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; SAVARS.LSP Generic routines for saving selected system variables before executing
;;; external applications, and restoring them afterward.
;;; Tee Square Graphics - http://www.turvill.com/t2/
;;; --------------------------------------------------------------------------------- ;;;
;; (arcvar...) creates a global list from the list contained
;; in the calling program consisting of the listed System
;; Variables and their current values.
;;
;; (revars) restores the System Variables that may have been
;; modified by the calling program to the values saved by
;; the (savars...) function
;;
;;example usage (arcvar (list "cmdecho" "plinewid"))

(defun arcvar (va)
(setq varsis '())
(repeat (length va)
(setq
varsis (append varsis (list (cons (car va) (getvar (car va)))))
)
(setq va (cdr va))
)
)
;;
(defun resvar ()
(repeat (length varsis)
(setvar (caar varsis) (cdar varsis))
(setq varsis (cdr varsis))
)
)

;;; --------------------------------------------------------------------------------- ;;;
;;;; Detentore errori sistema
;;; --------------------------------------------------------------------------------- ;;;

;;; Internal error handler
;;;
(defun attrerrCfl (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(if (/= s "Funzione annullata")
(princ)
(progn
(princ (strcat "\n !! programma interrotto !! : "))
(command "_.undo" "_end")
(command "_.undo" "")
)
)
(resvar) ; restore saved modes
(setq *error* olderr) ; restore old *error* handler
(princ)
)
;;;

;;; ===================== load-time error checking ============================
;;;
(defun ai_abort (app msg)
(defun *error* (s)
(if old_error (setq *error* old_error))
(princ)
);defun

(if msg
(alert (acet-str-format " Errore dell'applicazione: %1 \n\n %2 \n" app msg))
);alert
(exit)
);defun_ai_abort

;;; --------------------------------------------------------------------------------- ;;;
;;; kojacek - forum.cad.pl
;;; Numero convertito in stringa in unitא correnti e accuratezza
;;; soppressione zero finali
;;; uso (CAL_Rtos 100.00111110001888888 T) -> "100.001111100019"
;;; (CAL_Rtos 100.00111110001888888 nil) -> "100.0011"
;;; --------------------------------------------------------------------------------- ;;;
(defun CAL_RtoS (Val Mode / DMZ res)
(setq DMZ (getvar "DIMZIN"))
(setvar "DIMZIN"
(if (member (getvar "LUNITS")(list 4 5)) 0 8)
)
(setq res
(rtos
Val (getvar "LUNITS")
(if Mode 12 (getvar "LUPREC"))
)
)
(setvar "DIMZIN" DMZ)
res
)

;;; --------------------------------------------------------------------------------- ;;;
;;; CreaFinLAY predisposizione Layer supporto e Stile_Txt
;;; --------------------------------------------------------------------------------- ;;;
(defun CreaLayStyTXT (/)
(setq LayFIN (cdr (assoc 2(tblsearch "layer" "cfCornice"))) ;; layer Finestre
LayAnnFIN (cdr (assoc 2(tblsearch "layer" "cfEtichetta"))) ;; layer TestoAnnotazioneScala
StyTxt (cdr (assoc 2(tblsearch "style" "cfFinlay"))) ;; stile testo Finestre
)
(if (not LayFIN)
(progn
(setq LayFIN "cfCornice")
(Crea_Layer LayFIN "" "Continuous" "-3" "1" "0")
)
)
(if (not LayAnnFIN)
(progn
(setq LayAnnFIN "cfEtichetta")
(Crea_Layer LayAnnFIN "" "Continuous" "-3" "1" "1")
)
)
(if (not StyTxt)
(progn
(setq StyTxt "cfFinlay")
(if (= nil (findfile (strcat (getenv "Windir") "\\fonts\\arial.ttf")))
(Crea_StileTXT StyTxt "isocp.shx" 0)
(Crea_StileTXT StyTxt "arial.ttf" 0)
)
)
)
(setq LayDim (cdr (assoc 2(tblsearch "layer" "Dim"))))
(if (not LayDim)
(progn
(command "_.-layer" "_make" "Dim" "_color" "7" "" "")
(setq LayDim "Dim")
)
)

(setq StyDTxt (cdr (assoc 2(tblsearch "style" "Dim"))))
(if (not StyDTxt)
(progn
(setq StyDTxt "Dim")
(if (not (findfile (strcat (getenv "Windir") "\\fonts\\arial.ttf")))
(Crea_StileTXT StyDTxt "isocp.shx" 0)
(Crea_StileTXT StyDTxt "arial.ttf" 0)
)
)
)

) ;_ fine CreaLayStyTXT

;;; --------------------------------------------------------------------------------- ;;;
;;; crea layer
;;; -Plot sarא 1 or 0 (Plot or no Plot)
;;; -spessore puע essere .05 per .05 o -3 per default
;;; (Crea_Layer "Nome" "Descrizione" "continuous" "spessore" "colore" "plot")
;;; --------------------------------------------------------------------------------- ;;;
(defun Crea_Layer (Layer Descrizione TipoDiLinea SpessoreLin Colore Plot / VLA-Obj)
;;; aggiunge il tipolinea se non giא presente
(if (not (tblsearch "LTYPE" TipoDiLinea))
(command "_.-linetype" "_L" TipoDiLinea "acadiso.lin" "")
)
;;; Lista per EntMake
(entmake
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 70 0)
(cons 2 Layer)
(cons 62 (atoi Colore))
(cons 6 TipoDiLinea)
(cons 370 (atoi SpessoreLin))
(cons 290 (atoi Plot))
)
)
;; Crea layer descrizione
(if (>= (atof (getvar "acadver")) 16.1)
(progn
(setq Layers (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
(setq VLA-Obj (vla-Add Layers Layer))
(vla-Put-Description VLA-Obj Descrizione)
(vlax-release-object VLA-Obj)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Crea StileTesto
;;; (Crea_StileTXT "cfFinlay" "isocpeur.ttf" 0)
;;; --------------------------------------------------------------------------------- ;;;
(defun Crea_StileTXT (StileNome FontNome TxtAlt /)
(entmake
(list
(cons 0 "STYLE")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbTextStyleTableRecord")
(cons 2 StileNome) ;; Style Name
(cons 70 0)
(cons 40 TxtAlt) ;; Fixed text height
(cons 41 1.0) ;; Width Factor
(cons 50 0.0) ;; Oblique angle
(cons 71 0)
(cons 42 TxtAlt) ;; Last height used
(cons 3 FontNome) ;; Primary font name
(cons 4 "") ;; Big font name
)
)
)

;;; --------------------------------------------------------------------------------- ;;;
;; Piercey, Jason - Creating dimstyles with VL -
;; Arguments: Type, description:
;; Name: string, dimstyle name
;; VarLst: list, list of lists '((VarName VarValue)) or nil
;; Return: VlaObject of the dimstyle
;;; --------------------------------------------------------------------------------- ;;;
(defun DimSetup (Name VarLst / Obj)
(cond
(VarLst
(mapcar '(lambda (x)
(vla-setvariable *doc* (car x) (cadr x))
)
VarLst
)
(setq Obj (vla-add *dims* Name))
(vla-copyfrom Obj *doc*)
(vla-put-activedimstyle *doc* Obj)
)
(T (setq Obj (vla-add *dims* Name)))
)
Obj
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Disattiva/Attiva Elementi DCL necessari
;;; --------------------------------------------------------------------------------- ;;;
(defun congela (/)
; = CreDimScala "1"
(mode_tile "$LAY" 1)
(mode_tile "$WS" 1)
(mode_tile "$RET" 1)
(mode_tile "$CER" 1)
(mode_tile "$ELI" 1)
(mode_tile "$POL" 1)
(mode_tile "$DST" 0)
)
(defun scongela (/)
; = CreDimScala "0"
(mode_tile "$LAY" 0)
(mode_tile "$WS" 0)
(mode_tile "$RET" 0)
(mode_tile "$CER" 0)
(mode_tile "$ELI" 0)
(mode_tile "$POL" 0)
(mode_tile "$DST" 1)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; XDAdd aggiunge informazioni XDATA all'ultima entitא disegnata
;;; Xdata di Unitא e Scala della finestra creata
;;; --------------------------------------------------------------------------------- ;;;
(defun XDAdd ( / VlaxEntity xdatas DxfTypes)
;;; selezione l'ultimo oggetto creato
(setq VlaxEntity (vlax-ename->vla-object (entlast)))
;;;imposta i valori per Xdata
(setq xdatas (BuildArrays '(1001 1000 1000)
(list "CreaFinLay" (strcat "Drawing Units " UnitXD) (strcat "Scale " Sca))
)
)
(setq DxfTypes (nth 0 xdatas) DxfValues (nth 1 xdatas))
;;;aggiorna il valore dxf nell'oggetto
(vla-setXData VlaxEntity DxfTypes DxfValues)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; BuildArrays funzione utilizzata da XDAdd
;;; Autodesk "XDATA_VARIANTS.LSP"
;;; --------------------------------------------------------------------------------- ;;;
(defun BuildArrays (DxfTypes dxfValues / ListLength Counter Code VarValue
ArrayTypes ArrayValues VarTypes VarValues
Result)
;; Get length of the lists
(setq ListLength (1- (length DxfTypes)))
;; Create the safearrays for the dxf group code and value
(setq ArrayTypes (vlax-make-safearray vlax-vbInteger (cons 0 ListLength))
ArrayValues (vlax-make-safearray vlax-vbVariant (cons 0 ListLength)))
;; Set the array elements
(setq Counter 0)
(while ( "Scala le quote al Layout"
;;; La quotatura deve avvenire dal Layout nella rispettiva finestra scalata
;;; ogni finestra avrא le quote scalate nelle rispettive proporzioni.
;;; Secondo la norma "UNI EN ISO 3098-0" La gamma delle dimensioni nominali
;;; per le altezze di scrittura ט: 1,8 mm; 2,5 mm; 3,5 mm; 5 mm; 7 mm; 10 mm; 14 mm; 20 mm.
;;; --------------------------------------------------------------------------------- ;;;
(defun StiliDIM (/)
(setq *doc* (vla-get-activedocument (vlax-get-acad-object)) *dims* (vla-get-dimstyles *doc*))
;Stile ARCHITETTONICO
(setq StyDimARCHI (cdr (assoc 2(tblsearch "dimstyle" "Architectural"))))
(if (not StyDimARCHI)
(DimSetup "Architectural"
'(("DIMASZ" 2) ;;; Dimensione freccia
("DIMBLK" "_Small") ;;; Freccia
("DIMCLRT" 4) ;;; Colore testo
("DIMDEC" 0) ;;; Precisione
("DIMDLE" 1.25) ;; Estensione linea di quota
("DIMDLI" 8) ;;; Spaziatura linea di quota
("DIMEXE" 1.25) ;; Estensione linea d'estensione:
("DIMEXO" 5) ;;; Offset linea d'estensione
("DIMATFIT" 1) ;;; disposizione testo e frecce
("DIMGAP" 0.5) ;;; Offset testo
("DIMLFAC" 100) ;;; Scala lunghezza (misure in cm)
("DIMSCALE" 0) ;;; Scala generale
("DIMTMOVE" 2) ;;; Adatta: spostamento testo
("DIMTOFL" 1) ;;; Forza la linea entro le linee di estensione
("DIMTOH" 1) ;;; Allineamento testo esterno
("DIMTXSTY" "Dim") ;;; Stile di testo
("DIMTXT" 2.5) ;;; Altezza del testo
("DIMZIN" 0) ;;; Soppressione degli zeri
("DIMTIX" 1) ;;; Disegna il testo tra le linee di estensione
("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
; Stile MECCANICO
(setq StyDimMECCA (cdr (assoc 2(tblsearch "dimstyle" "Mechanical"))))
(if (not StyDimMECCA)
(DimSetup "Mechanical"
'(("DIMASZ" 2.5) ;;; Dimensione freccia
("DIMBLK" ".") ;;; Freccia
("DIMCLRT" 4) ;;; Colore testo
("DIMDEC" 0) ;;; Precisione
("DIMDLE" 0) ;;; Estensione linea di quota
("DIMDLI" 8) ;;; Spaziatura linea di quota
("DIMEXE" 1.25) ;; Estensione linea d'estensione:
("DIMEXO" 1) ;;; Offset linea d'estensione
("DIMATFIT" 1) ;;; disposizione testo e frecce
("DIMGAP" 0.5) ;;; Offset testo
("DIMLFAC" 1000) ;;; Scala lunghezza (misure in mm)
("DIMSCALE" 0) ;;; Scala generale
("DIMTMOVE" 2) ;;; Adatta: spostamento testo
("DIMTOFL" 1) ;;; Forza la linea entro le linee di estensione
("DIMTOH" 1) ;;; Allineamento testo esterno
("DIMTXSTY" "Dim") ;;; Stile di testo
("DIMTXT" 2.5) ;;; Altezza del testo
("DIMZIN" 0) ;;; Soppressione degli zeri
("DIMTIX" 1) ;;; Disegna il testo tra le linee di estensione
("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
; Stile STANDARD
(setq StyDimSTAND (cdr (assoc 2(tblsearch "dimstyle" "cf-Standard"))))
(if (not StyDimSTAND)
(DimSetup "cf-Standard"
'(("DIMASZ" 2.5) ;;; Dimensione freccia
("DIMBLK" ".") ;;; Freccia
("DIMCLRT" 4) ;;; Colore testo
("DIMDEC" 2) ;;; Precisione
("DIMDLE" 0) ;;; Estensione linea di quota
("DIMDLI" 8) ;;; Spaziatura linea di quota
("DIMEXE" 1.25) ;; Estensione linea d'estensione:
("DIMEXO" 1) ;;; Offset linea d'estensione
("DIMATFIT" 1) ;;; disposizione testo e frecce
("DIMGAP" 0.5) ;;; Offset testo
("DIMLFAC" 1) ;;; Scala lunghezza (misure in m)
("DIMSCALE" 0) ;;; Scala generale
("DIMTMOVE" 2) ;;; Adatta: spostamento testo
("DIMTOFL" 1) ;;; Forza la linea entro le linee di estensione
("DIMTOH" 1) ;;; Allineamento testo esterno
("DIMTXSTY" "Dim") ;;; Stile di testo
("DIMTXT" 2.5) ;;; Altezza del testo
("DIMZIN" 0) ;;; Soppressione degli zeri
("DIMTIX" 1) ;;; Disegna il testo tra le linee di estensione
("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
)
;;; fine StiliDIM

;;; --------------------------------------------------------------------------------- ;;;
;;; Lista Stili Quota non generati da "CreaStyDim"
;;; is request to load AI_UTILS
;;; --------------------------------------------------------------------------------- ;;;
(Defun ListaDimStili (/)
(setq ListaDS nil)
(setq Index 0)
(setq p nil)
(setq dimstyle_names (acad_strlsort (ai_table "DIMSTYLE" 0)))
(progn
(while (nth index dimstyle_names)
(Progn
(setq p (nth index dimstyle_names))
(vl-string-search "k" p)
(if (= (vl-string-search "k" p) nil)
(setq ListaDS (append ListaDS (list p)))
)
(setq index (+ 1 index))
)
)
)
(setq index 0)
;;; fine creazione lista Stili quota
(start_list "$DST")
(mapcar 'add_list ListaDS)
(end_list)
(if (or(= DS_nlst nil) (> DS_nlst (length ListaDS)))
(if (member "cfStandard" ListaDS)
(set_tile "$DST" (itoa (vl-position "cf-Standard" ListaDS)))
(set_tile "$DST" "0")
)
(set_tile "$DST" (itoa DS_nlst))
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;;;;; CreaStyDim predispone lo stile di quota
;;; --------------------------------------------------------------------------------- ;;;
(defun CreaStyDim (/)
(setq PrefStyDim (strcat (substr (getvar "dimstyle") 1 3)" "))
(setq NewDim (strcat PrefStyDim Unit$ " " (vl-string-subst "k" ":" Sca))
StyDim (cdr (assoc 2(tblsearch "dimstyle" NewDim)))
)
(cond
((not StyDim)
(if (or (= "cfA " PrefStyDim) (= "cfM " PrefStyDim))
(setq Dim_Dec 0) ; 0 Cifre decimali
(setq Dim_Dec 2) ; 2 Cifre decimali (= "m" Unit$)
)

(DimSetup NewDim
(list (list "DIMDEC" Dim_Dec) ;;; Precisione
(list "DIMSCALE" (/ 1 (distof FattZoom 2))) ;;; Scala generale
(cond
((and (= "cfA " PrefStyDim) (= "m" Unit$)) '("DIMLFAC" 100)) ;;; Scala lunghezza (misure in m)
((and (= "cfA " PrefStyDim)(= "cm" Unit$)) '("DIMLFAC" 1))
((and (= "cfA " PrefStyDim)(= "mm" Unit$)) '("DIMLFAC" 0.1))

((and (= "cfM " PrefStyDim)(= "m" Unit$)) '("DIMLFAC" 1000))
((and (= "cfM " PrefStyDim)(= "cm" Unit$)) '("DIMLFAC" 10))
((and (= "cfM " PrefStyDim)(= "mm" Unit$)) '("DIMLFAC" 0.1))

((and (= "cfS " PrefStyDim)(= "m" Unit$)) '("DIMLFAC" 1))
((and (= "cfS " PrefStyDim)(= "cm" Unit$)) '("DIMLFAC" 0.01))
((and (= "cfS " PrefStyDim)(= "mm" Unit$)) '("DIMLFAC" 0.001))

( T '("DIMLFAC" 1))
)
'("DIMTOH" 1) ;;; Allineamento testo esterno
'("DIMTXSTY" "Dim") ;;; Stile di testo
'("DIMFXLON" 1) ;;; Controllo linee estensione impostate su lunghezza fissa
'("DIMFXL" 5.0) ;;; Imposta lunghezza totale linee di estensione
)
)
)
)
)

;;; --------------------------------------------------------------------------------- ;;;
; Set current dim style by lisp command
; Tharwat - http://www.cadtutor.net
; uso (_SetDimStyleCurrent "cfArchitettonico")
;;; --------------------------------------------------------------------------------- ;;;
(defun _SetDimStyleCurrent (dim / acdoc)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(if (tblsearch "DIMSTYLE" dim)
(vla-put-activeDimstyle
acdoc
(vla-item (vla-get-Dimstyles acdoc) dim)
)
)
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; lista layout
;;; --------------------------------------------------------------------------------- ;;;
;; ר GetLays ר (Lee Mac) ;;
;; ~ Retrieves a list of Layout VLA-Objects, ;;
;; excluding the Model tab, sorted in Tab order. ;;

(defun GetLays (/ lst)
(or lay (setq lay (vla-get-layouts
(vla-get-ActiveDocument
(vlax-get-acad-object)))))

(vlax-for ly lay
(and (not (eq "Model" (vla-get-Name ly)))
(setq lst (cons ly lst))))

(vl-sort lst
(function
(lambda (a b)
( Lay_nlst (length L_LAY)))
(set_tile "$LAY" "0")
(set_tile "$LAY" (itoa Lay_nlst))
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; immagine logo Generata da VECTORIZE.lsp di Richard Willis
;;; ;********************************************************************************
;;; ; Function to draw a vector image within a dialogue Image tile or Image Button. *
;;; ; Argument: 'DCLKEY' - the dcl key of the image tile/button to be filled. *
;;; ; Do NOT edit the dcl dimension text below, this is needed by Vectorize. *
;;; ;********************************************************************************
;;; ; Compiled for dcl dimensions of width,8.26, height,3.82, *
;;; ;********************************************************************************
;;; --------------------------------------------------------------------------------- ;;;
(defun LogoCFL (DCLKEY / i j)
(setq i (/ (dimx_tile DCLKEY) 51.) j (/ (dimy_tile DCLKEY) 51.))
(start_image DCLKEY)
(fill_image 0 0 (dimx_tile DCLKEY)(dimy_tile DCLKEY) -15)
(foreach x '((5 10 7 10 250) (7 10 7 7 250) (7 7 5 7 250) (5 7 5 10 250)
(6 9 6 2 250) (6 9 13 9 250) (6 9 6 15 250) (6 9 0 9 250)
(4 40 5 41 1) (5 41 5 41 1) (5 41 6 41 1) (6 41 6 41 1)
(6 41 6 40 1) (6 40 6 40 1) (6 40 6 40 1) (6 40 5 40 1)
(5 40 4 40 1) (4 40 3 40 1) (3 40 3 40 1) (3 40 2 40 1)
(2 40 2 40 1) (2 40 2 40 1) (2 40 1 41 1) (1 41 1 42 1)
(1 42 1 42 1) (1 42 1 43 1) (1 43 2 43 1) (2 43 2 44 1)
(2 44 5 45 1) (5 45 5 45 1) (5 45 5 46 1) (5 46 6 46 1)
(6 46 6 47 1) (6 47 5 47 1) (5 47 5 47 1) (5 47 4 48 1)
(4 48 4 48 1) (4 48 3 47 1) (3 47 2 47 1) (2 47 2 47 1)
(2 47 2 47 1) (2 47 1 47 1) (1 47 1 47 1) (1 47 1 48 1)
(1 48 1 48 1) (1 48 2 48 1) (2 48 3 48 1) (3 48 4 48 1)
(4 48 4 49 1) (4 49 5 48 1) (5 48 5 48 1) (5 48 6 48 1)
(6 48 6 48 1) (6 48 6 47 1) (6 47 7 46 1) (7 46 7 46 1)
(7 46 6 45 1) (6 45 6 45 1) (6 45 5 44 1) (5 44 3 43 1)
(3 43 2 42 1) (2 42 2 42 1) (2 42 2 41 1) (2 41 2 41 1)
(2 41 3 41 1) (3 41 3 40 1) (3 40 4 40 1) (10 42 10 42 1)
(10 42 9 43 1) (9 43 9 43 1) (9 43 8 44 1) (8 44 8 47 1)
(8 47 8 47 1) (8 47 9 48 1) (9 48 9 48 1) (9 48 10 49 1)
(10 49 12 49 1) (12 49 12 48 1) (12 48 12 48 1) (12 48 12 48 1)
(12 48 10 48 1) (10 48 10 47 1) (10 47 9 47 1) (9 47 9 44 1)
(9 44 10 43 1) (10 43 10 43 1) (10 43 12 43 1) (12 43 12 43 1)
(12 43 12 43 1) (12 43 12 43 1) (12 43 12 42 1) (12 42 10 42 1)
(14 46 14 47 1) (14 47 14 47 1) (14 47 14 48 1) (14 48 15 48 1)
(15 48 16 49 1) (16 49 18 49 1) (18 49 18 48 1) (18 48 18 44 1)
(18 44 18 43 1) (18 43 18 43 1) (18 43 17 42 1) (17 42 16 42 1)
(16 42 15 42 1) (15 42 14 43 1) (14 43 14 43 1) (14 43 15 43 1)
(15 43 16 43 1) (16 43 17 43 1) (17 43 17 44 1) (17 44 17 45 1)
(17 45 16 45 1) (16 45 15 45 1) (15 45 15 45 1) (15 45 14 46 1)
(14 46 14 46 1) (15 47 15 47 1) (15 47 15 46 1) (15 46 16 46 1)
(16 46 17 46 1) (17 46 17 48 1) (17 48 16 48 1) (16 48 15 47 1)
(20 40 20 40 1) (20 40 20 47 1) (20 47 20 47 1) (20 47 20 48 1)
(20 48 21 48 1) (21 48 21 49 1) (21 49 21 49 1) (21 49 22 48 1)
(22 48 21 47 1) (21 47 21 40 1) (21 40 21 40 1) (21 40 20 40 1)
(25 47 25 47 1) (25 47 25 46 1) (25 46 25 46 1) (25 46 27 46 1)
(27 46 27 48 1) (27 48 25 48 1) (25 48 25 47 1) (37 48 38 49 1)
(38 49 38 49 1) (38 49 38 48 1) (38 48 38 40 1) (38 40 38 40 1)
(38 40 37 40 1) (37 40 35 41 1) (35 41 35 42 1) (35 42 35 42 1)
(35 42 36 42 1) (36 42 36 42 1) (36 42 37 41 1) (37 41 37 48 1)
(24 46 24 47 1) (24 47 24 47 1) (24 47 24 48 1) (24 48 25 48 1)
(25 48 25 49 1) (25 49 28 49 1) (28 49 28 48 1) (28 48 28 44 1)
(28 44 28 43 1) (28 43 28 43 1) (28 43 27 42 1) (27 42 26 42 1)
(26 42 25 42 1) (25 42 24 43 1) (24 43 24 43 1) (24 43 25 43 1)
(25 43 26 43 1) (26 43 27 43 1) (27 43 27 44 1) (27 44 27 45 1)
(27 45 25 45 1) (25 45 25 45 1) (25 45 24 45 1) (24 45 24 46 1)
(24 46 24 46 1) (40 47 40 47 1) (40 47 40 47 1) (40 47 40 48 1)
(40 48 40 48 1) (40 48 40 48 1) (40 48 41 48 1) (41 48 41 47 1)
(41 47 40 47 1) (40 47 40 47 1) (40 47 40 47 1) (40 47 40 47 1)
(40 47 40 47 1) (40 47 40 47 1) (40 47 40 47 1) (40 43 40 44 1)
(40 44 40 44 1) (40 44 40 44 1) (40 44 40 44 1) (40 44 41 44 1)
(41 44 41 44 1) (41 44 40 43 1) (40 43 40 43 1) (40 44 40 44 1)
(40 44 40 44 1) (40 44 40 44 1) (40 44 40 44 1) (40 44 40 44 1)
(40 44 40 44 1) (46 45 50 45 30) (50 45 50 17 30) (50 17 15 17 30)
(15 17 15 38 30))
(vector_image (fix (* (car x) i))(fix (* (cadr x) j))(fix (* (caddr x) i))(fix (* (cadddr x) j))(last x))
)
(end_image)
(princ)
);_fine LogoCFL

;;; --------------------------------------------------------------------------------- ;;;
;;;Controllo Unitא Disegno
;;; --------------------------------------------------------------------------------- ;;;
(defun m_cm_mm (/)
(if(not Unit$)
(progn
(setq Unit$ "m" Convert 1000.0 UnitXD "Meter")
(mode_tile "$M" 2)
)
)
(if(= "m" Unit$)
(progn
(setq Convert 1000.0 UnitXD "Meter")
(mode_tile "$M" 2)
)
)
(if(= "cm" Unit$)
(progn
(setq Convert 10.0 UnitXD "Cantimeter")
(mode_tile "$CM" 2)
)
)
(if(= "mm" Unit$)
(progn
(setq Convert 1.0 UnitXD "Millimeter")
(mode_tile "$MM" 2)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Controllo Forma della finestra di layout
;;; --------------------------------------------------------------------------------- ;;;
(defun FormaFin (/)
(if (not Forma$)
(progn
(setq Forma$ "RET")
(mode_tile "$RET" 2)
)
)
(if (= "RET" Forma$)
(progn
(setq Forma$ "RET")
(mode_tile "$RET" 2)
)
)
(if (= "CER" Forma$)
(progn
(setq Forma$ "CER")
(mode_tile "$CER" 2)
)
)
(if (= "ELI" Forma$)
(progn
(setq Forma$ "ELI")
(mode_tile "$ELI" 2)
)
)
(if (= "POL" Forma$)
(progn
(setq Forma$ "POL")
(mode_tile "$POL" 2)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Controllo Rotazione vista della finestra di layout
;;; --------------------------------------------------------------------------------- ;;;
(defun RotVP0 (/)
(cond ((/= (getvar "viewtwist") 0)
(command "_.dview" "_c" (getvar "vsmax") (getvar "vsmin") "" "_tw" 0 "")
(setvar "SNApang" 0)
)
)
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Cancella VIEWPORT esistenti
;;; --------------------------------------------------------------------------------- ;;;
(defun CancVport (/)
(progn (setq ssvp (ssget "X" '((0 . "VIEWPORT"))))
(setq n 0)
(if ssvp
(while (<= (setq n (1+ n)) (sslength ssvp))
(entdel (ssname ssvp (1- n)))
)
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra rettangolare
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportRET (/ Ang Diag Pt1 Pt2 Pt2Lay Ptmed)
(setvar "clayer" LayFIN)
(setq Pt1 (getpoint "\nSpecify first window corner: "))
(setq Pt2 (getcorner pt1 "\nSpecify opposite corner: "))
(setq Ang (angle pt1 pt2))
(setq Diag (distance pt1 pt2))
(setq PtMed (polar Pt1 Ang (/ Diag 2)))
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Adatta")
(progn
(setq Pt2Lay (polar '(0 0) Ang (* Diag (atof FattZoom))))
(command "_.dragmode" "_auto")
(setvar "osmode" 0)
(command "_.-vports" "0,0" Pt2Lay)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq NumVP (cdr (assoc 69 Ent)))
(command "_.zoom" "_w" "0,0" Pt2Lay)
(command "_.mspace")
(setvar "cvport" NumVP)
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_c" Ptmed ScXP)
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" Entname "" "0,0" pause )
(command "_.mview" "_l" "_on" Entname "")
)
);fine IF /= Adatta
(if (= SCA "Adatta")
(progn
(setq Wc1 (getpoint "\nSpecify first window corner: "))
(princ "\nSpecify opposite corner: ")
(command "_.-vports" Wc1 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq NumVP (cdr (assoc 69 Ent)))
(command "_.mspace")
(setvar "cvport" NumVP)
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" Pt1 Pt2)
(command "_.pspace")
(Command "zoom" "_all")
(command "_.mview" "_l" "_on" Entname "")
(setq WriteScala "0")
)
);fine IF Adatta
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra Cerchio
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportCER (/ Pt1 Centro Radius RadiusLay)
(setvar "clayer" LayFIN)
(setq Pt1(getpoint "\nSpecify center point of circle: "))
(princ "\nSpecify radius of circle: ")
(command "_.circle" Pt1 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq Radius (cdr (assoc 40 Ent)))
(command "_.erase" entname "")
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Adatta")
(progn
(setq RadiusLay (* Radius (atof FattZoom)))
(setvar "osmode" 0)
(command "_.circle" (strcat (rtos RadiusLay) "," (rtos RadiusLay)) RadiusLay)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(command "_.-vports" "_o" Entname)
(setq NumVP (cdr (assoc 69 Ent)))
(setq Wc1 (POLAR (list (* 1.4142 RadiusLay) (* 1.4142 RadiusLay) 0.0) (/ (* 5 PI) 4) RadiusLay))
(setq Wc2 (POLAR (list (* 1.4142 RadiusLay) (* 1.4142 RadiusLay) 0.0) (/ PI 4) RadiusLay))
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(Command "zoom" "_c" Pt1 ScXP)
(command "_.pspace")
(Command "zoom" "_all")
(command "_.dragmode" "_auto")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" Entname "" (strcat (rtos RadiusLay) "," (rtos RadiusLay)) pause)
(command "_.mview" "_l" "_on" Entname "")
)
);fine IF /= Adatta
(if (= SCA "Adatta")
(progn
(setq Wc1 (getpoint "\nSpecify center point of circle: "))
(princ "\nSpecify radius of circle: ")
(command "_.circle" Wc1 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq RadiusLay (cdr (assoc 40 Ent)))
(command "_.-vports" "_o" Entname)
(setq NumVP (cdr (assoc 69 Ent)))
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" (POLAR PT1 (/ (* 5 PI) 4) (* 1.4142 Radius)) (POLAR PT1 (/ PI 4) (* 1.4142 Radius)))
(command "_.pspace")
(Command "zoom" "_all")
(command "_.mview" "_l" "_on" Entname "")
(setq WriteScala "0")
)
);fine IF Adatta
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra Ellisse
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportELI (/ Ang Diag Pt1 Pt2Lay PtMed Centro CentroLay MDiag2 Mdiag2Lay
Pt1R Rap)
(if (/= "PELLIPSE" 0)(setvar "PELLIPSE" 0))
;0 Crea un oggetto ellisse vero.
;1 Crea la rappresentazione di un'ellisse in forma di polilinea
(setvar "clayer" LayFIN)
(setq Pt1(getpoint "\nSpecifies the start point of the axis: "))
(setq Pt2(getpoint Pt1 "\nSpecifies the end point of the axis: "))
(princ "\nSpecifies the length of the Second half-axis: ")
(command "_.ellipse" Pt1 Pt2 pause)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq Centro (cdr (assoc 10 Ent)))
(setq Rap (cdr (assoc 40 Ent))) ;rapporto tra asse minore e asse maggiore
(setq Pt1R (cdr (assoc 11 Ent))) ;punto finale asse maggiore rispetto al centro
(setq Ang (angle Pt1 Pt2))
(setq Diag (distance Pt1 Pt2))
(setq PtMed (polar Pt1 Ang (/ Diag 2)))
(if (= (rtos (/ (distance Pt1 Pt2) 2)2 2) (rtos (distance '(0.0 0.0 0.0) Pt1R)2 2))
(setq MDiag2 (/ (* Diag Rap) 2))
(setq MDiag2 (/ (/ Diag Rap) 2))
)
(command "_.erase" entname "")
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Adatta")
(progn
(setq Pt2Lay (polar '(0 0) Ang (* (distance Pt1 Pt2) (atof FattZoom))))
(setq Mdiag2Lay (* Mdiag2 (atof FattZoom)))
(setvar "osmode" 0)
(command "_.ellipse" "0,0" Pt2Lay Mdiag2Lay)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(setq CentroLay (cdr (assoc 10 Ent)))
(setq PtRagMag (cdr (assoc 11 Ent)))
(command "_.-vports" "_o" Entname)
(setq EntVP (entget (entlast)));; setta viewport
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
(setq Wc1 (list (- (car PC_SC)(/ Larg_SC 2))(- (cadr PC_SC) (/ Alt_SC 2))))
(setq Wc2 (list (+ (car PC_SC)(/ Larg_SC 2))(+ (cadr PC_SC) (/ Alt_SC 2))))
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;;controlla rotazione vista nella finestra
(command "_.zoom" "_c" Ptmed ScXP)
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" Entname "" CentroLay pause)
(command "_.mview" "_l" "_on" Entname "")
)
);fine IF /= Adatta
(if (= SCA "Adatta")
(progn
(setq Wc1 (getpoint "\nSpecify the center of the ellipse: "))
(princ "\nSpecify the length of the major semi-axis: ")
(setq Wc2 (strcat "@" (rtos (car Pt1R))"," (rtos (cadr Pt1R))))
(setvar "osmode" 0)
(command "_.ellipse" "_c" Wc1 Wc2 Mdiag2)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(command "_.-vports" "_o" Entname)
(setq EntVP (entget (entlast)));; setta viewport
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
(setq Wc1M (list (- (car Centro)(/ Larg_SC 2))(- (cadr Centro) (/ Alt_SC 2))))
(setq Wc2M (list (+ (car Centro)(/ Larg_SC 2))(+ (cadr Centro) (/ Alt_SC 2))))
(command "_.dragmode" "_auto")
(command "_.Scale" Entname "" Wc1 "_r" Wc1 Wc2 pause)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" (trans Wc1M 0 1) (trans Wc2M 0 1))
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(command "_.mview" "_l" "_on" Entname "")
(setq WriteScala "0")
)
);fine IF Adatta
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Finestra Polilinea
;;; --------------------------------------------------------------------------------- ;;;
(Defun VportPOL (/ Pt1)
(setvar "clayer" LayFIN)
;(command "_.undo" "_be")
(princ "\n.....Draw Polyline ")
(setq Pt1 (getpoint "\nFrom Point: "))
(princ "\nNext Point [Undo / ]: ")
(command "_.pline" Pt1 pause)
(while (> (getvar "cmdactive") 0)
(progn
(princ "\nNext Point [Undo / ]]: ")
(command pause))
)
(command "_.pedit" "_l" "_c" "_x")
;(command "_.undo" "_e")
(setq Ent (entget (entlast)))
(setq EntNamePModel (cdr (assoc -1 Ent)))
(ListaVertPL_CFL)
(setvar "CTAB" Lay)
(if (/= 1 (getvar "cvport"))(command "_.Pspace"))
(if (/= SCA "Adatta")
(progn
(setvar "osmode" 0)
(NDrawListaVerticiPOL)
(setq Ent (entget (entlast)))
(setq EntNamePLay (cdr (assoc -1 Ent)))
(command "_.scale" EntNamePLay "" "0,0" FattZoom)
(command "_.-vports" "_o" EntNamePLay)
(setq EntVP (entget (entlast)));; setta viewport
(setq EntNamePLayVP (cdr (assoc -1 EntVP))) ;; nome
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
;(setq PC_SM (cdr (assoc 12 EntVP))) ;; punto centrale VP nello spazio modello
(setq NumVP (cdr (assoc 69 EntVP)))
(setq Wc1 (list (- (car PC_SC)(/ Larg_SC 2))(- (cadr PC_SC) (/ Alt_SC 2))))
(setq Wc2 (list (+ (car PC_SC)(/ Larg_SC 2))(+ (cadr PC_SC) (/ Alt_SC 2))))
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_c" PtCen ScXP)
(command "_.erase" EntNamePModel "")
(command "_.pspace")
(Command "zoom" "_all")
(setvar "osmode" oldsnap)
(princ "\nSpecify insertion point of viewport in Layout: ")(princ)
(command "_.move" EntNamePLay "" "0,0" pause)
(command "_.mview" "_l" "_on" EntNamePLay "")
)
);fine IF /= Adatta
(if (= SCA "Adatta")
(progn
(setvar "osmode" 0)
(setq Wc0 (getpoint "\nSpecify the position of the first point of the polygon: "))
(command "_.ucs" "_n" Wc0)
(NDrawListaVerticiPOL)
(setq Ent (entget (entlast)))
(setq EntNamePLay (cdr (assoc -1 Ent)))
(command "_.-vports" "_o" EntNamePLay)
(setq EntVP (entget (entlast)));; setta viewport
(setq EntNamePLayVP (cdr (assoc -1 EntVP))) ;; nome
(setq PC_SC (cdr (assoc 10 EntVP)));; punto centrale VP nello spazio carta
(setq Larg_SC (cdr (assoc 40 EntVP))) ;; larghezza massima VP nello spazio carta
(setq Alt_SC (cdr (assoc 41 EntVP)));; altezza massima VP nello spazio carta
;(setq PC_SM (cdr (assoc 12 EntVP))) ;; punto centrale VP nello spazio modello
(setq NumVP (cdr (assoc 69 EntVP)))
(setq Wc1 (list (- (car PC_SC)(/ Larg_SC 2))(- (cadr PC_SC) (/ Alt_SC 2))))
(setq Wc2 (list (+ (car PC_SC)(/ Larg_SC 2))(+ (cadr PC_SC) (/ Alt_SC 2))))
(princ "\nSpecifiy the reference length for enlargement / reduction: ")
(command "_.Scale" EntNamePLay "" "0,0" "_r" (sqrt(+ (expt Larg_SC 2)(expt Alt_SC 2))) pause)
(command "_.ucs" "_W" "")
(command "_.zoom" "_w" Wc1 Wc2)
(command "_.mspace")
(RotVP0) ;;; controlla rotazione vista nella finestra
(command "_.zoom" "_w" (trans Ptmin 0 1) (trans Ptmax 0 1))
(command "_.erase" EntNamePModel "")
(command "_.pspace")
(Command "_.zoom" "_all")
(setvar "osmode" oldsnap)
(command "_.mview" "_l" "_on" EntNamePLay "")
(setq WriteScala "0")
)
);fine IF Adatta
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Crea lista vertici finestra poligonale
;;; --------------------------------------------------------------------------------- ;;;
(Defun ListaVertPL_CFL (/)
(setq ListaV nil)
(setq Index 0)
(progn
(while (nth index Ent)
(Progn
(setq p (nth index Ent)) ;Direzione di estrusione
(if (= (car p) 10)
(setq ListaV (append ListaV (list (cdr p))))
)
(setq index (+ 1 index))
)
)
)
(setq ListaV (append ListaV (list (nth 0 ListaV))))
(setq nrVertici (- (length ListaV) 1))
(setq index 0)
;;;--------------------------------------------------------
;; trova coordinate minime, massime e centro finestra poligonale
;;(Defun Lista_minmax_XY (/)
(setq IndexC 0)
(progn
(while (nth indexC ListaV)
(Progn
(setq pC (nth indexC ListaV))
(if (/= (car pC) nil)
(progn
(setq ListaVX (append ListaVX (list (car pC))))
(setq ListaVY (append ListaVY (list (cadr pC))))
)
)
(setq indexC (+ 1 indexC))
)
)
)
(setq ListaVX (append ListaVX (list (nth 0 ListaVX))))
(setq ListaVY (append ListaVY (list (nth 0 ListaVY))))
(setq indexC 0)

(setq minX (eval (append '(min) ListaVX))
minY (eval (append '(min) ListaVY))
maxX (eval (append '(max) ListaVX))
maxY (eval (append '(max) ListaVY)))

(setq Ptmin (list minX minY)
Ptmax (list maxX maxY))
;; trans 0 1
;; Translates a point (or a displacement) from one coordinate system to another
;;0 World (WCS) 1 User (current UCS)
(setq PtCen (trans (inters (list minX minY)(list maxX maxY)(list minX maxY)(list maxX minY))0 1))
;) ;; Fine Lista_minmax_XY
;;;--------------------------------------------------------
;;; calcola la finestra poligonale con coordinate inizio spostate nel punto 0,0
(setq IndexC 0)
(progn
(while (nth indexC ListaV)
(Progn
(setq pC (nth indexC ListaV))
(if (/= (car pC) nil)
(setq NListaV
(append NListaV
(list (list (- (car pC) (car (car ListaV)))
(- (cadr pC) (cadr (car ListaV)))
)
)
)
)
)
(setq indexC (+ 1 indexC))
)
)
)
(setq indexC 0)
);; Fine ListaVertPL_CFL
;;; --------------------------------------------------------------------------------- ;;;
;;; disegna polilinea da lista vertici
;;; --------------------------------------------------------------------------------- ;;;
(defun NDrawListaVerticiPOL (/)
(command "_.pline")
(apply 'command NListaV)
(command "")
(command "_.pedit" "_l" "_c" "_x")
)
;;; --------------------------------------------------------------------------------- ;;;
;;; calcola ScalaFinLay
;;; --------------------------------------------------------------------------------- ;;;
(defun ScalaFinLay(/)
(setq Sca_nlst (atoi (get_tile "$LSCA")))
;************************************************************************
;**** se SCA = "Adatta" allora VALSCA =0 e FATTZOOM = "0" e SCXP = "0xp"
;************************************************************************
(setq Sca (nth Sca_nlst L_SCA))
(setq ValSca (atoi (vl-string-subst "" "1:" Sca)))
(if
(and (= 0 (vl-string-position (ascii "1") Sca)) (= 1 (vl-string-position (ascii ":") Sca)))
(setq FattZoom (CAL_RtoS (/ Convert ValSca) T)) ;; Fattore ZoomXP scala Riduzione
(setq FattZoom (CAL_RtoS (* Convert ValSca) T)) ;; Fattore ZoomXP scala ingrandimento
)
(if (/= Sca "Adatta")
(setq ScXP (strcat FattZoom "xp"))
(setq ScXP "Adatta")
)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; Scrive Scala con Testo Multilinea
;;; --------------------------------------------------------------------------------- ;;;
(defun ScriveScala_TM (/)
(setvar "clayer" LayAnnFIN)
(setvar "textstyle" StyTxt)
(setq $a (cons 40 5.0))
(setq $b (cons 1 (strcat "{\\L\\P\\l\\H0.7x;Scale " Sca "}"))) ;testo decrizione H 5mm sottolineato e scala H3.5mm non sottolineata
(setq $c (cons 10 '(0.0 0.0 0.0)))
(entmake (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(7 . "cfFinlay")
'(71 . 5)
'(90 . 3) ;;; Maschera di sfondo con colore sfondo disegno
'(45 . 1.2) ;;; Fattore Offset Bordo
$a $b $c
)
)
(setq Ent (entget (entlast)))
(setq Entname (cdr (assoc -1 Ent)))
(command "_.copyclip" Entname "")
(command "_.erase" Entname "")
(princ "\nSpecify the insertion point of the Scale annotation: ")(princ)
(command "_.pasteclip" pause)
(setq Ent (entget (entlast)))
;;; presenta il testo in modo editazione
;;; (setvar "regenmode" 0)
;;; (vl-cmdf "_.Zoom" "_c" (cdr (assoc 10 Ent)) (* (cdr (assoc 40 Ent))30))
;;; (vl-cmdf "_.ddedit" (cdr (assoc -1 Ent))"")
;;; (vl-cmdf "_.Zoom" "_p")
;;;
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Total number of viewports in current layout
;;; (1- (sslength (ssget "_X" (list '(0 . "VIEWPORT") (cons 410 (getvar "CTAB"))))))
;;; --------------------------------------------------------------------------------- ;;;
;;; calcolo Numero ViewPort in tutti i Layout
;;; --------------------------------------------------------------------------------- ;;;
(defun AllViewports (/ active_document nvp)
(setq nvp 0)
(setq active_document
(vla-get-activedocument (vlax-get-Acad-Object))
)
(vlax-for item (vla-get-blocks active_document)
(if (wcmatch (vla-get-name item) "*Paper*")
(vlax-for object item
(if (= (vla-get-objectname object) "AcDbViewport")
(Setq nvp (+ 1 nvp))
)
)
)
)
(setq NumVP (- nvp (length (layoutlist))))
(princ)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; inizio "CFL_CreaFinLay_37-DCL.lsp"
;; ***************************************************
;; created with: Dcl2Lisp.lsp by Charles Alan Butler
;; create_dcl function to create a dcl support
;; file if it does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_dcl (fn / acadfn)
(if (null(wcmatch (strcase fn) "*`.DCL"))
(setq fn (strcat fn ".DCL"))
)
(if (not (findfile (strcat (getvar "roamablerootprefix") fn)))
;; create dcl file
(progn
(setq fn (strcat (getvar "roamablerootprefix") fn)
fn (open fn "w")
)
(foreach x '(
"//------------------------------------------------------"
"// \"CreaFinLay.LSP\""
"// \"CreaFinLay.DCL\""
"//------------------------------------------------------"
"//CreaFinLayout Dialog"
"dcl_settings : default_dcl_settings { audit_level = 3; }"
"CreaFinLayout : dialog {"
"label = \" Layout ViewPort Creator (translated by Igal Averbuh 2018) \";"
"spacer ;"
" : row { "
" : column { //colonna 1"
" : row {"
" : boxed_radio_column {"
" label = \"ViewPort Form \";"
" : radio_button {"
" label = \"Rectangle\"; "
" key = \"$RET\";"
" }"
" : radio_button {"
" label = \"Circle\"; "
" key = \"$CER\";"
" }"
" : radio_button {"
" label = \"Ellipse\"; "
" key = \"$ELI\";"
" }"
" : radio_button {"
" label = \"Polyline\"; "
" key = \"$POL\";"
" }"
" }"
" : column {"
" : boxed_radio_row {"
" label = \"Draw Units\";"
" : radio_button {"
" label = \"mm\"; "
" key = \"$MM\";"
" }"
" : radio_button {"
" label = \"cm\"; "
" key = \"$CM\";"
" }"
" : radio_button {"
" label = \"m\"; "
" key = \"$M\";"
" }"
" }"
" : boxed_column {"
" label = \"Select Scale \";"
" :row {"
" :column {"
" : text { "
" key = \"$ScXP\";"
" label = \"\";"
" alignment = centered;"
" width = 20 ;"
" }"
" }"
" }"
" :row {"
" : popup_list {"
" key = \"$LSCA\"; "
" width = 15 ; fixed_width = true;"
" allow_accept = false;"
" }"
" // spacer;"
" : button { "
" width= 4; "
" fixed_width = true; "
" key=\"$EdSca\"; "
" label= \"Edit\"; "
" alignment = centered;"
" } "
" }"
" spacer;"
" }"
" }"
" }"
" :column {"
" :row { "
" : boxed_column { "
" label = \"Select Layout\";"
" : popup_list {"
" key = \"$LAY\"; "
" // width = 37; fixed_width = true;"
" allow_accept = false;"
" }"
" spacer ;"
" }"
" } "
" spacer ; "
" : row {"
" : boxed_column {"
" label = \"Opcional \";"
" : toggle {"
" label = \"Annotation Scale\"; "
" key = \"$WS\"; "
" value = \"0\";"
" }"
" : toggle {"
" label = \"Create Dimmension Style\"; "
" key = \"$CSD\"; "
" value = \"0\";"
" }"
" : popup_list {"
" label = \"from Style:\";"
" key = \"$DST\"; "
" width = 30 ; "
" allow_accept = false;"
" }"
" spacer ; "
" } "
" : column {"
" spacer ;"
" }"
" : column {"
" spacer ; "
" : image {"
" alignment = centered; "
" key = \"vectors\"; "
" width = 8.26; "
" height = 3.82; "
" fixed_width = true; "
" fixed_height = true; "
" aspect_ratio = 1; "
" color = -15;"
" }"
" : text { "
" key = \"$rc0\";"
" label = \"\";"
" width = 21 ; "
" alignment = centered;"
" }"
" : text { "
" key = \"$rc1\";"
" label = \"\";"
" width = 21 ; "
" alignment = centered;"
" }"
" spacer ; "
" } //fine column"
" : column {"
" spacer ;"
" } "
" }"
" }"
" }"
" } //fine colonna 1"
" spacer ; "
" spacer ;"
" ok_cancel_help;"
"spacer ;"
"}"
""
" EditaScale : dialog { label = \" \";"
" key=\"ESLabel\";"
" spacer_1;"
" : row {"
" spacer;"
" : column { width= 18;"
" : list_box { key=\"LB1\";"
" width = 17;"
" fixed_width = true;"
" }"
" }"
" : column {"
" : edit_box { key = \"EB2\"; }"
" spacer;"
" : button { width= 12; key=\"BTA\"; label= \"Add\"; }"
" : button { width= 12; key=\"BTU\"; label= \"Modify\"; }"
" : button { width= 12; key=\"BTD\"; label= \"Delete\"; }"
" spacer;"
" spacer;"
" spacer;"
" : button { width= 12; key=\"BTR\"; label= \"Restore\"; }"
" spacer;"
" }"
" spacer;"
" }"
" spacer_1;"
" ok_cancel;"
" spacer_1;"
" }"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\n File DCL creation. "
"\n
Restart the routine again"
"\n in case of error."))
t ; return True, file created
) ; end progn
t ; return True, file found
) ; endif
) ; end defun
;;; fine "CFL_CreaFinLay_37-DCL.lsp"

;;; inizio RW_FileScale
;;; --------------------------------------------------------------------------------- ;;;
;;; lista scale da file esterno escludendo i commenti
;;; --------------------------------------------------------------------------------- ;;;
(defun LeggiFileScale(/ wPath)
(setq L_SCA (list))
(if (setq wPath (findfile "ACAD.PAT"))
(progn
(setq wPath (vl-filename-directory wPath))
(or (eq "\\" (substr wPath (strlen wPath)))
(setq wPath (strcat wPath "\\")))
t)
nil)

(cond
((not (findfile (strcat wPath Appl ".sca")))
(RestoreButton)
)
)
(setq FileRead (open (strcat wPath Appl ".sca") "r"))
(while (setq aline (read-line FileRead))
(if (/= (substr aline 1 1) "#") ;; carattere # inizio riga commento
(if (/= aline "")
(progn
(setq aline (list aline))
(setq L_SCA (append L_SCA aline))
)
)
)
)

(close FileRead)

(start_list "$LSCA")
(mapcar 'add_list L_SCA)
(end_list)

(if (or(= Sca_nlst nil) (> Sca_nlst (- (length L_SCA) 1))) ;19
;;(set_tile "$LSCA" "7") ;imposta come valore standard "1:100"
;(setq UnoCento (vl-position "1:100" L_SCA) ) ;;;Returns the index of the specified list item
(if (null (vl-position "1:100" L_SCA))
(set_tile "$LSCA" "0")
(set_tile "$LSCA" (itoa (vl-position "1:100" L_SCA)))
)
(set_tile "$LSCA" (itoa Sca_nlst))
)
)

;;; --------------------------------------------------------------------------------- ;;;
;;; Scrive lista su file riga per riga
;;; --------------------------------------------------------------------------------- ;;;
(defun ScriviFileScale(L_SCA / wPath)

(if (setq wPath (findfile "ACAD.PAT"))
(progn
(setq wPath (vl-filename-directory wPath))
(or (eq "\\" (substr wPath (strlen wPath)))
(setq wPath (strcat wPath "\\")))
t)
nil)

(setq FileWrite (open (strcat wPath Appl ".sca") "w"))
(mapcar '(lambda (Str) (write-line Str FileWrite)) L_SCA)
(close FileWrite)
)
;;; --------------------------------------------------------------------------------- ;;;
;;; verifica digitazione nuova scala
;;; --------------------------------------------------------------------------------- ;;;
(defun VerificaSca (VSca / El VSL_sca Sx Dx MsgErrNu MsgErrDe)
(setq MsgErrNu 0
MsgErrDe 0
)
(setq VSL_sca (vl-string->list Vsca))
(setq El (ascii ":"))
(cond ((not (member El VSL_sca))
(setq MsgErrNu 1
MsgErrDe 1)
)
)
(cond ((member El VSL_sca)
(setq Sx (reverse (cdr (member El (reverse VSL_sca))))) ;; lista elementi Sx elemento scelto
(if (/= Sx nil)
(progn
(foreach n Sx
(if (/= (isdigit n) T)
(setq MsgErrNu 1)
)
) ;; end foreach
)
(setq MsgErrNu 1)
) ;fine if
(setq Dx (cdr (member El VSL_sca))) ;; lista elementi Dx elemento scelto
(if (and (/= Dx nil) (/= (car Dx) 48)) ;; non nullo e non 0 come primo numero
(progn
(foreach n Dx
(if (/= (isdigit n) T)
(setq MsgErrDe 1)
)
) ;; end foreach
)
(setq MsgErrDe 1)
) ;fine if
)
)
(cond ((and (= MsgErrNu 1) (= MsgErrDe 0))
(alert " error in the numerator!")
)
((and (= MsgErrNu 0) (= MsgErrDe 1))
(alert " error in the denominator!")
)
((and (= MsgErrNu 1) (= MsgErrDe 1))
(alert "\n Value not allowed!")
)
((and (= MsgErrNu 0) (= MsgErrDe 0))
(setq Sca Sca)
)
)
)
;;;---------------------
(defun isdigit (code)
(or
( (length localListData) 0)
(progn
(setq localListData (ArchSort localListData)) ;;;richiede "SortListLeeMac.lsp"
(start_list "LB1")
(mapcar 'add_list localListData)
(end_list)
;;;****
(cond ((= BT 0)
(if (>= (read localListPick) (length localListData))
(setq localListPick (itoa (1- (length localListData))))
)
)
((= BT 1)
(setq localListPick (itoa (vl-position TX localListData)))
)
((= BT 2)
(setq localListPick (itoa 6)) ;;; punta al valore 1:100 nel caso di ripristino scale di default
)
)
;;;**** sostuito ultima posizione LB1 con quella appena digitata nel caso di ADD
(set_tile "LB1" localListPick)
(listBoxCallBack localListPick)
)
(progn
(start_list "LB1")
;;; (add_list "* EMPTY *")
(add_list "* VUOTO *")
(end_list)
;;; (setq localListData '("*"))
(cond
((= Appl "CreaFinLay")(setq localListData '("Adatta")))
)
)
)
)

; Copyright ©2007 - Marc'Antonio Alessi, Italy - All rights reserved
; http://xoomer.virgilio.it/alessi
;
; Function: ALE_ReplaceFirst - 22/01/2005
;
; Version 1.01
;
; 24/01/2005 - added new local (EndLst) to correct return
; value if OldItm is not member of In_Lst
;
; Description:
; returns a copy of the list with a new item substituted
; in place of the first old item in the list
; If NewItm = nil OldItm is removed
;
; Arguments:
; NewItm = An atom or list
; OldItm = An atom or list
; In_Lst = A list
; InRLst = Original list reversed
;
; Return Values:
; A list
; the original list if OldItm is not member of the list
;
; Examples:
; (setq alist '(0 1 2 3 4 3 5 3 6 3 3 7))
;
; (ALE_ReplaceFirst "NEW" 3 alist (reverse alist))
; Returns: (0 1 2 "NEW" 4 3 5 3 6 3 3 7)
;
; (ALE_ReplaceFirst '(9 . Z) 3 alist (reverse alist))
; Returns: (0 1 2 (9 . Z) 4 3 5 3 6 3 3 7)
;
; (ALE_ReplaceFirst nil 3 alist (reverse alist))
; Returns: (0 1 2 4 3 5 3 6 3 3 7)
;
(defun ALE_ReplaceFirst (NewItm OldItm In_Lst InRLst / NthPos EndLst)
(if (setq EndLst (member OldItm In_Lst))
(progn
(setq NthPos (- (length InRLst) (length EndLst)))
(while
(/=
NthPos
(length (setq InRLst (cdr (member OldItm InRLst))))
)
)
(append (reverse InRLst) (if NewItm (list NewItm)) (cdr EndLst))
)
In_Lst
)
)

; Marc'Antonio Alessi - http://xoomer.virgilio.it/alessi
; Function: ALE_List_RemoveNth
;
; Version 2.02 - 15/02/2008 > old name: ALE_RemoveNth
; Version 1.02 - 16/06/2007
; Version 1.00 - 2001
;
; Description:
; returns a copy of the list without the nth item
;
; Arguments:
; NthPos = Integer - nth like
; In_Lst = A list
; InRLst = Original list reversed
;
; Examples:
;
; (setq alist '((0 . "A") (1 . "B") nil (3 . "D") (4 . "E") nil))
; => ((0 . "A") (1 . "B") nil (3 . "D") (4 . "E") nil)
;
; (ALE_List_RemoveNth 0 alist (reverse alist))
; => ((1 . "B") nil (3 . "D") (4 . "E") nil)
;
; (ALE_List_RemoveNth 2 alist (reverse alist))
; => ((0 . "A") (1 . "B") (3 . "D") (4 . "E") nil)
;
; (ALE_List_RemoveNth 4 alist (reverse alist))
; => ((0 . "A") (1 . "B") nil (3 . "D") nil)
;
; (ALE_List_RemoveNth 5 alist (reverse alist))
; => ((0 . "A") (1 . "B") nil (3 . "D") (4 . "E"))
;
; (ALE_List_RemoveNth 6 alist (reverse alist))
; => ((0 . "A") (1 . "B") nil (3 . "D") (4 . "E") nil)
;
;;; (setq L_SCA (list "1:1" "1:2" "1:5" "1:20" "1:25" "1:50" "1:100" "1:200" "1:250" "Add"))
;;; (ALE_List_RemoveNth 6 L_SCA (reverse L_SCA))

(defun ALE_List_RemoveNth (NthPos In_Lst InRLst / LstLng OldItm)
(cond
( (null In_Lst) nil )
( (zerop NthPos) (cdr In_Lst) )
( (<= (setq LstLng (length In_Lst)) NthPos) In_Lst )
( (zerop (setq LstLng (- LstLng (1+ NthPos))))
(reverse (cdr InRLst))
)
( T
(setq OldItm (nth NthPos In_Lst))
(while
(/=
NthPos
(length (setq InRLst (cdr (member OldItm InRLst))))
)
)
(while
(/=
LstLng
(length (setq In_Lst (cdr (member OldItm In_Lst))))
)
)
(append (reverse InRLst) In_Lst)
)
)
)
;;
;; keep on programmin'
;;; fine "Edita_Scale"
;;; --------------------------------------------------------------------------------- ;;;

;;; inizio SortListLeeMac
;;; --------------------------------------------------------------------------------- ;;;
;;; da: "www.theswamp.org/forum" SortList di Gile & LeeMac
;;; uso:
;;;(setq L_SCA (list "1:200" "1:1" "1:500" "1:5" "2:1" "Add" "1:20" "1:5000" ))
;;;(ArchSort L_SCA)
;;; --------------------------------------------------------------------------------- ;;;
;; ר ArchSort ר (Gile) ;;
;; ~ Sorts a list of strings by numerical ;;
;; values, then by Prefix/Suffix. ;;
;;; --------------------------------------------------------------------------------- ;;;
(defun ArchSort (lst / comparable comp x1 x2)
(defun comparable (e1 e2)
(or (and (numberp e1) (numberp e2))
(= 'STR (type e1) (type e2))
(not e1)
(not e2)))
(mapcar
(function
(lambda (x)
(nth x lst)))
(vl-sort-i (mapcar 'SplitStr lst)
(function
(lambda (x1 x2 / n1 n2 comp)
(while
(and (setq comp (comparable (setq n1 (car x1))
(setq n2 (car x2))))
(= n1 n2))
(setq x1 (cdr x1) x2 (cdr x2)))
(if comp (list str)
test (chr (car lst)))
(if (< 47 (car lst) 58)
(setq num T))
(while (setq lst (cdr lst))
(if num
(cond ((= 46 (car lst))
(if (and (cadr lst)
(setq tmp (strcat "0." (chr (cadr lst))))
(numberp (read tmp)))
(setq rslt (cons (read test) rslt) test tmp lst (cdr lst))
(setq rslt (cons (read test) rslt) test "." num nil)))
((< 47 (car lst) 58)
(setq test (strcat test (chr (car lst)))))
(T (setq rslt (cons (read test) rslt) test (chr (car lst)) num nil)))
(if (< 47 (car lst) 58)
(setq rslt (cons test rslt) test (chr (car lst)) num T)
(setq test (strcat test (chr (car lst)))))
)
)
(if num
(setq rslt (cons (read test) rslt))
(setq rslt (cons test rslt)))
(reverse rslt)
)
;;;---------------
;; ר toTop ר (Lee Mac) ;;
;; ~ Moves the nth item in a list to the ;;
;; 0th position. ;;
;;;uso: (setq L_SCA (toTop 6 L_SCA))
(defun toTop (i lst)
(cond ((zerop i) lst)
((append (list (nth i lst))
(remove_nth i lst))))
)
;;;---------------
;; ר Remove_nth ר (Lee Mac) ;;
;; ~ Removes the nth item in a list. ;;
;;; uso: (setq L_SCA (Remove_nth 0 L_SCA))
(defun Remove_nth (i lst / j)
(setq j -1)
(vl-remove-if
(function
(lambda (x)
(eq i (setq j (1+ j))))) lst)
)
;;;---------------
;;; ADJOIN - adds element to list, if not already in it
;;; uso: (ADjoin "1:251" L_SCA)
(defun ADjoin (item lst)
(cond ((member item lst) lst)
(t (cons item lst)))
)
;;;---------------
;;; Remove - remove element from list,
;;; uso: (Remove "1:251" L_SCA)
(defun Remove (expr lst)
(apply 'append (subst nil (list expr) (mapcar 'list lst)))
)

;;; fine SortListLeeMac

;;; inizio CFL_GestFinLay_3
;;; --------------------------------------------------------------------------------- ;;;
;;; Program from "Command Line" windows management
;;; --------------------------------------------------------------------------------- ;;;
(defun C:-GFL (/ SELEZio )
(initget "Block sbLock Lock WheelAll Congelayers Isolayers Scongelayers ?")
(setq SELEZ "Blocca")
(setq SELEZio (getkword (strcat " Windows - Block / sbLock / Wheel / BlockAll / Congelayers / Isolayers / Scongelayers /? ")))
(if (/= nil SELEZio)(setq SELECT SELEZio))
(C:GFL)
(princ)
) ;;fine GFL - gestione Finestre da "Riga Di Comando"

;;; --------------------------------------------------------------------------------- ;;;
;;; Programma gestione Finestre
;;; --------------------------------------------------------------------------------- ;;;
(defun C:GFL (/ lst SS thisdwg Ent Ent1 Ent-N i L lst N olderr Plock_VP SNA
TWA SS1 MsgRot lst2 #LA)
(setq olderr *error*
*error* attrerr
)

; Salva le variabili di sistema
(arcvar (list "cmdecho" "clayer" "osmode" "angbase" "aunits"))
(setvar "cmdecho" 0)
(command "_.undo" "_begin")
(cond
((= SELEZ "Scongelayers")
;;; ---------------------------------------------------------------------
;;; Funzione Scongela Tutti i Layer nella viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((> (getvar "cvport") 1)
(command "_.pspace")
)
)
(cond
((= (getvar "cvport") 1)
(princ "\n Choose the ViewPort to thaw All layers")
(setq SS (ssget ":E:S" '((0 . "Viewport"))))
(cond (( /= SS nil)
(setq SS (cdr (assoc 69 (entget (ssname SS 0)))))
(command "_.mspace")
(setvar "cvport" SS)
(command "_.vplayer" "_t" "*" "_c" "")
(command "_.pspace")
(prompt "\nAll layers have been thawed.")(princ)
)
)
)
)
)
)
;;; ---------------------------------------------------------------------
)
((= SELEZ "Isolayers")
;;; ---------------------------------------------------------------------
;;; Funzione Isola il/i Layer nella viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((= (getvar "cvport") 1)
(command "_.mspace"))
)
(cond
((> (getvar "cvport") 1)
(setq SS1 (ssget))
(if SS1
(progn
(setq Ent (entget (ssname SS1 0)))
(setq #LA (cdr (assoc 8 Ent)))
(setq L 1)
(setq N (sslength SS1)
)
(while ( (getvar "cvport") 1)
(setq SS1 (ssget))
(if SS1
(progn
(setq Ent (entget (ssname SS1 0)))
(setq #LA (cdr (assoc 8 Ent)))
(setq L 1)
(setq N (sslength SS1)
)
(while (ename ent))))
(vla-put-color (vlax-ename->vla-object (cdr ent1)) 256) ; color 256 (dalayer)
)
)
)
)
)
)
;;; (command "_.regenall")
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
;;; Select Viewports but not Layouts
;;; (ssget "x" '((0 . "VIEWPORT") (-4 . "/=") (69 . 1)))
(if (/= (setq SS (ssget "x" '((0 . "VIEWPORT") (-4 . "/=") (69 . 1))))nil)
(cond
((> (sslength SS) 1)(Alert (strcat "\nAll "(itoa (sslength SS))" virew port are locked.")))
((= (sslength SS) 1)(Alert (strcat "\nOnly one viewport has been locked.")))
)
(Alert (strcat "\nThere are no viewports in the drawing."))
)
)
((= SELEZ "sbLocca")
;;; ---------------------------------------------------------------------
;;; Funzione Sblocca la/e viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((/= (getvar "cvport") 1)
(command "_.pspace")
)
)
(cond
((= (getvar "cvport") 1)
;;;------------VPLock.lsp----------------------
;;; Purpose: Lock/Unlock Viewports by Selection
;;; Author : Herman Mayfarth
;;; Date : 1 July 2004
;;; Version: 1.0
;;; Copyright © 2004 Herman Mayfarth
;;; All rights reserved.
;;; Supplied "as is," and without warranty, express or implied.
;;; Permission granted to use & redistribute without fee,
;;; Provided file header including copyright notice remains intact.
;;;---------------------------------------------------------------
;;;unlocks viewports
;;; (defun C:VPUnlock ( / lst SS thisdwg)
;(vl-load-com)
(setq thisdwg (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark thisdwg)
(princ "\nSelect Viewport to Unlock: ")
(and
(setq SS (ssget '((0 . "VIEWPORT")(-4 . "/=") (69 . 1))))
;;;build a list of enames from the SS
(setq i 0)
(repeat (sslength SS)
(setq lst (cons (ssname SS i) lst))
(if (/= (assoc 340 (entget (ssname SS i))) nil)
(setq lst2 (cons (cdr (assoc 340 (entget (ssname SS i))))lst2))
)
(setq i (1+ i))
);repeat
;;;convert the enames to vla-objects
;;;and unlock the viewports
(mapcar '(lambda (x)
(vla-put-displaylocked (vlax-ename->vla-object x) :vlax-false)
(vla-put-color (vlax-ename->vla-object x) 170) ;;;setta colore 170 :blue
);lambda
lst
);mapcar
(mapcar '(lambda (x)
(vla-put-color (vlax-ename->vla-object x) 170) ;;;setta colore 256 :dalayer (40 orange)
);lambda
lst2
);mapcar
);and
(vla-endundomark thisdwg)
(princ)
(cond
((> (sslength SS) 1)(Alert (strcat "\n"(itoa (sslength SS))" viewports in the drawing has been unlocked.")))
((= (sslength SS) 1)(Alert (strcat "\nOne viewport in the drawing has been unlocked.")))
)
(princ)
);C:VPUnlock
)
)
)
)
((= SELEZ "Blocca")
;;; ---------------------------------------------------------------------
;;; Funzione Blocca la/e viewport
;;; ---------------------------------------------------------------------
(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
)
(cond
((/= (getvar "ctab") "Model")
(cond
((/= (getvar "cvport") 1)
(command "_.pspace")
)
)
(cond
((= (getvar "cvport") 1)
;;;------------VPLock.lsp----------------------
;;; Purpose: Lock/Unlock Viewports by Selection
;;; Author : Herman Mayfarth
;;; Date : 1 July 2004
;;; Version: 1.0
;;; Copyright © 2004 Herman Mayfarth
;;; All rights reserved.
;;; Supplied "as is," and without warranty, express or implied.
;;; Permission granted to use & redistribute without fee,
;;; Provided file header including copyright notice remains intact.
;;;---------------------------------------------------------------
;;;locks viewports
;;; (defun C:VPLock ( / lst SS thisdwg)
;(vl-load-com)
(setq thisdwg (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark thisdwg)
(princ "\nSelect Viewports to Lock: ")
;(princ "\n Scegli le Finestre da Bloccare: ")
(and ;in lieu of (if SS ..) following sget
;;; (setq SS (ssget '((0 . "VIEWPORT"))))
(setq SS (ssget '((0 . "VIEWPORT")(-4 . "/=") (69 . 1))))
;;;build a list of enames from the SS
(setq i 0)
(repeat (sslength SS)
(setq lst (cons (ssname SS i) lst))
(if (/= (assoc 340 (entget (ssname SS i))) nil)
(setq lst2 (cons (cdr (assoc 340 (entget (ssname SS i))))lst2))
)
(setq i (1+ i))
);repeat
;;;convert the enames to vla-objects
;;;and lock the viewports
(mapcar '(lambda (x)
(vla-put-displaylocked (vlax-ename->vla-object x) :vlax-true)
(vla-put-color (vlax-ename->vla-object x) 256) ;;;setta colore 256 :dalayer (40 orange)
);lambda
lst
);mapcar
(mapcar '(lambda (x)
(vla-put-color (vlax-ename->vla-object x) 256) ;;;setta colore 256 :dalayer (40 orange)
);lambda
lst2
);mapcar
);and
(vla-endundomark thisdwg)
(princ)
(cond
((> (sslength SS) 1)(Alert (strcat "\n"(itoa (sslength SS))" viewports in the drawing has been locked.")))
((= (sslength SS) 1)(Alert (strcat "\nOne viewport in the drawing has been locked.")))
)
(princ)
);C:VPLock
)
)
)
)
((= SELEZ "Wheel")
;;; ---------------------------------------------------------------------
;;; Funzione Ruota la vista nella viewport
;;; (setvar "angbase" 0)
;;; (setvar "aunits" 0)
;;; ---------------------------------------------------------------------
(cond
((= SELEZ "Wheel")
(cond
((= (getvar "ctab") "Model")
(ALERT "\n ** Attension **\n\nYou are about to Rotate \ nThe Viewport !!! \n ")
)
)
(cond
((= (getvar "cvport") 1)
(command "_.mspace")
)
)
(princ "Choose points for horizontal alignment or write the angle of rotation: ")
;;; setq TWA (getangle))
(setq TWA (* (getangle) -1))
(setq SNA (* TWA -1))
;;; (setq TWA (angtos TWA (getvar "aunits")))
(setq TWA (angtos TWA (getvar "aunits") 4))
(cond
((/= (getvar "ctab") "Model")
;;; Unlock active Viewport
(if (equal :vlax-true
(vla-get-DisplayLocked
(vla-get-ActivePViewport
(vlax-get-property (vlax-get-acad-object) "ActiveDocument")
)
)
)
(progn
(vla-put-DisplayLocked
(vla-get-ActivePViewport
(vlax-get-property (vlax-get-acad-object) "ActiveDocument")):vlax-false)
(setq Plock_VP "BLO")
)
(setq Plock_VP "APE")
)
;;;end Unlock active Viewport
)
)
;;; (command "_.dview" "" "_tw" TWA "")
(command "_.dview" "_c" (getvar "vsmax") (getvar "vsmin") "" "_tw" TWA "")
(setvar "SNApang" SNA)
(cond
((/= (getvar "ctab") "Model")
;;; Lock active Viewport
(if (= Plock_VP "BLO")
(vla-put-DisplayLocked
(vla-get-ActivePViewport
(vlax-get-property (vlax-get-acad-object) "ActiveDocument")):vlax-true)
)
;;; End Lock active Viewport
)
)
(command "_.pspace")
(vla-Regen (vla-get-ActiveDocument (vlax-get-acad-object)) acAllViewports)
(setq MsgRot (strcat "\n View rotation: " (rtos (atof TWA)2 2) (chr 176)))
(princ MsgRot)
)
)
)
((= SELEZ "?")
;;; ---------------------------------------------------------------------
;;; Guida
;;; ---------------------------------------------------------------------
(InfoGFL)
;;; ---------------------------------------------------------------------
)
) ;;fine cond
(princ)
(command "_.undo" "_end")
;; Ripristina le variabili di sistema al valore iniziale - Tee Square Graphics
(resvar)
(princ)
) ;;fine GFL - gestione Finestre
;;; fine CFL_GestFinLay_3

;;; inizio CFL_Info_6
;;; --------------------------------------------------------------------------------- ;;;
;;; from info YAD's 'INFO.LSP'
;;; https://www.theswamp.org/index.php?topic=41239.0;nowap
;;; --------------------------------------------------------------------------------- ;;;
(defun c:FLinfo (/ name$ acaddoc olderr oldvar ss loop
gr pt ent oldent val oldlayer oldTxtStyle
oldsnap newstyle newlayer LayFIN LayAnnFIN StyTxt)

(setvar "cmdecho" 0)
;;; nomi layer stili
(setq LayFIN "cfCornice")
(setq LayAnnFIN "cfEtichetta")
;;; nomi stili
(setq StyTxt "cfFinlay")

(cond
((= (getvar "ctab") "Model")
(alert "\n** Command not allowed on the Model space **")
)
((and (/= (getvar "ctab") "Model") (= (length (vports)) 2))
(setq acaddoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark acaddoc)
(prompt "\n** Info CreaFinLay ** \n ** Esc/Invio per uscire **")
(setq olderr *error*
*error* myerr
oldvar (list (list "osmode" (getvar "osmode"))
(list "fillmode" (getvar "fillmode"))
)
ss (ssadd)
loop T
)

(setq oldsnap (getvar "osmode" ))
(command "_.undo" "_begin")

(setvar "osmode" 0)
(setvar "fillmode" 1)

(if (not (tblsearch "style" StyTxt)) ;;FinLay Finestre
(progn
(setq newstyle (vla-add (vla-get-textstyles acaddoc) StyTxt))
(vla-put-fontfile newstyle (strcat (getenv "Windir") "\\fonts\\arial.ttf"))

)
)
(if (not (tblsearch "layer" LayFIN)) ;;FinLay-Finestra Finestre
(progn
(setq newlayer LayFIN)
(setq newlayer (vla-add (vla-get-layers acaddoc) newlayer))
;;; (vla-put-LayerOn newlayer 1) ;;; ; set the layer on
(vla-put-color newlayer 40)
(vla-put-plottable newlayer :vlax-false)
;;; (vla-put-activeLayer acaddoc newlayer) ;;; ; set active layer
)
)
(if (not (tblsearch "layer" LayAnnFIN));;FinLay-Etichetta Fin-Sc Txt
(progn
(setq newlayer LayAnnFIN)
(setq newlayer (vla-add (vla-get-layers acaddoc) newlayer))
;;; (vla-put-LayerOn newlayer 1) ;;; ; set the layer on
(vla-put-color newlayer 1)
;;; (vla-put-activeLayer acaddoc newlayer) ;;; ; set active layer
)
)

(while loop
(setq gr (grread T 8))
(cond
((or (= (car gr) 12) (= (car gr) 5))
(setq pt (cadr gr))
(setq ent (nentselp pt))

(setq ent (if (and ent (= (type (last (last ent))) 'ename))
(last (last ent))
(car ent)
)
)
(if ent
(if (not (or (equal ent oldent) (ssmemb ent ss)))
(progn
(del_ss ss)
;;;----------*
(if (and
(or (= (dxf ent 0) "CIRCLE")
(= (dxf ent 0) "ELLIPSE")
(= (dxf ent 0) "LWPOLYLINE")
)
(dxf ent 330)
(= (dxf (dxf ent 330) 0) "VIEWPORT")
)
(setq ent (dxf ent 330))
)
;;;----------*
(redraw ent 3)
(dis_info ent)
(setq oldent ent)
)
)
(progn
(del_ss ss)
(setq oldent nil
ss (ssadd)
)
)
)
)
((= (car gr) 3)
(if oldent
;;; (if (= (getvar "cmdnames") "")
(if (and (= (getvar "cmdnames") "") (= name$ "VIEWPORT") (/= XDVALUE nil))
(progn
(sssetfirst nil (ssadd oldent))
;;; (vl-cmdf "_.properties")
(progn
(del_ss ss)
(setq oldent nil
ss (ssadd)
)
)
(add_Mtext)
(prompt "\n ** Esc / Enter to exit **")
)
(prompt "\n ** Esc / Enter to exit **")
)
)
)
(T (setq loop nil))
)
)
(del_ss ss)
(if (or (= (car gr) 12) (= (car gr) 25))
(sssetfirst)
)
(setq *error* olderr)
(foreach itm oldvar (setvar (car itm) (cadr itm)))
(vla-endundomark acaddoc)
(vlax-release-object acaddoc)
))
(princ)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun myerr (msg)
(del_ss ss)
(setq *error* olderr)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun dxf (ent n)
(if (= (type ent) 'ename)
(setq ent (entget ent))
)
(cdr (assoc n ent))
)
;;; --------------------------------------------------------------------------------- ;;;
(defun del_ss (ss / n)
(setq n -1)
(repeat (sslength ss)
(entdel (ssname ss (setq n (1+ n))))
)
(if oldent
(redraw oldent 4)
)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun add_solid (p1 p2 p3 p4)
(entmakex (list (cons 0 "SOLID")
(cons 100 "AcDbEntity")
(cons 62 40)
(cons 100 "AcDbTrace")
(cons 10 p1)
(cons 11 p2)
(cons 12 p3)
(cons 13 p4)
(cons 210 (trans (getvar "viewdir") 1 0))
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun add_text (pt h txt)
(entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 62 170)
(cons 100 "AcDbText")
(cons 10 pt)
(cons 40 h)
(cons 1 txt)
(cons 50 0.0)
(cons 7 StyTxt)
(cons 72 0)
(cons 73 0)
(cons 210 (trans (getvar "viewdir") 1 0))
)
)
)
;;; --------------------------------------------------------------------------------- ;;;
(defun add_Mtext (/ EntMT oldRigen)
(entmake (list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 7 StyTxt) ;;; stile testo
(cons 8 LayAnnFIN) ;;; layer
(cons 71 5) ;;; Punto di collegamento - mezzo centro
(cons 40 5.0) ;;; $a ;;; Altezza del testo nominale (iniziale)
(cons 90 3) ;;; Maschera di sfondo con colore sfondo disegno
(cons 45 1.2) ;;; Fattore Offset Bordo
;;; $b
(cons 1
(strcat "{\\L\\P\\l\\H0.7x;"
(vlax-variant-value (caddr (vlax-safearray->list XDVALUE)))
"}"
)
)
;;; $c
(cons 10 pt)
)
)

;;; presenta il testo in modo editazione
(setq EntMT (entget (entlast)))
(setq oldRigen (getvar "regenmode"))
(setvar "regenmode" 0)
(vl-cmdf "_.Zoom"
"_c"
(cdr (assoc 10 EntMT))
(* (cdr (assoc 40 EntMT)) 30)
)
(vl-cmdf "_.ddedit" (cdr (assoc -1 EntMT)) "")
(vl-cmdf "_.Zoom" "_p")
(setvar "regenmode" oldRigen)
(princ "\n")
)
;;; --------------------------------------------------------------------------------- ;;;
(defun dis_info (ent / obj lst h high width ang n)
(setq obj (vlax-ename->vla-object ent)
name$ (dxf ent 0)
)

(vla-getXData Obj "CreaFinLay" 'XDTYPE 'XDVALUE) ;;creaFinLayINFO
(if (/= XDVALUE nil)
(progn
(vla-getXData Obj "CreaFinLay" 'XDTYPE 'XDVALUE)
(mapcar
'(lambda (X Y)
(cons X Y)
)
(vlax-safearray->list XDTYPE)
(vlax-safearray->list XDVALUE)
)
(setq lst (list
(strcat " *** Info "
(vlax-variant-value (car (vlax-safearray->list XDVALUE)))
" *** "
)
(strcat
(vlax-variant-value (cadr (vlax-safearray->list XDVALUE)))
)
(strcat
(vlax-variant-value (caddr (vlax-safearray->list XDVALUE)))
)
)
)
)
(if (= name$ "VIEWPORT")
(setq lst (list
(strcat "** missing information **")
(strcat " not created with CreaFinLay "))
)
(setq lst (list ""))
)
)

(setq lst (append (list (car lst)) (cdr lst))
ss (ssadd)
h (/ (getvar "viewsize") 60)
high (* 1.80 h (length lst))
width (* 0.70 h (apply 'max (mapcar 'strlen lst)))
ang (angle (trans (getvar "viewctr") 1 2) (trans pt 1 2))
pt (trans (mapcar '+ pt (getvar "target")) 1 2)
ang (cond
((>= (/ pi 2) ang 0)
(list (list (- (car pt) width) (- (cadr pt) high) (caddr pt))
(list (- (car pt) width) (cadr pt) (caddr pt))
)
)
((>= pi ang (/ pi 2))
(list (list (+ (car pt) width) (- (cadr pt) high) (caddr pt))
pt
)
)
((>= (+ pi (/ pi 2)) ang pi)
(list (list (+ (car pt) width) (+ (cadr pt) high) (caddr pt))
(list (car pt) (+ (cadr pt) high) (caddr pt))
)
)
((>= (* 2 pi) ang (+ pi (/ pi 2)))
(list (list (- (car pt) width) (+ (cadr pt) high) (caddr pt))
(list (- (car pt) width) (+ (cadr pt) high) (caddr pt))
)
)
)
)
(ssadd (add_solid pt
(list (caar ang) (cadr pt) (caddr pt))
(list (car pt) (cadar ang) (caddr pt))
(car ang)
)
ss
)
(setq pt (cadr ang)
pt (list (+ (car pt) (* 0.5 h)) (cadr pt) (caddr pt))
)
(setq n -1)
(repeat (length lst)
(ssadd (add_text (setq pt (list (car pt) (- (cadr pt) (* 1.6 h)) (caddr pt)))
h
(nth (setq n (1+ n)) lst)
)
ss
)
)
)
;;; fine CFL_Info_6

;;; --------------------------------------------------------------------------------- ;;;
;;; messaggi guida
;;; --------------------------------------------------------------------------------- ;;;
(defun InfoCreaFinLay (/)
(msgbox
"Help - Create Layout ViewPorts"
32
"
The Window is automatically locked to prevent an accidental
zoom change in the window itself and then scale.
With the '' Annotate Scale '' option selected, ask where to place the
text with the value of the Scala. By editing it you can add the
description of the object represented (eg Plan / Prospectus / etc).
With the '' Create SOLO Dim Style '' option, a dimension style is created
associated with the scale and design units chosen and becomes the style of
current quota; the texts of the dimensions have a height corresponding to
2.5 mm (*) in the Paper Space.

Angelo Stocco - April 2016

"
)
)
(princ);_end
;;; --------------------------------------------------------------------------------- ;;;
(defun InfoGFL (/)
(msgbox
"Guida - Gestione Finestre di Layout"
32
"
''FLINFO'' Mostra infornazioni su unitא e scala della Finestra al
passaggio del puntatore; cliccandoci con il tasto sx del
mouse, inserisce l'annotazione della scala e apre l'editor
per completare la descrizione.

''-GFL'' opzioni:
> 'BLOCCA' la Visualizzazione della/e Finestra/e selezionata/e
ed applica alla finestra il colore ''DaLayer''.
> 'SBLOCCA' la Visualizzazione della/e Finestra/e selezionata/e
ed applica alla finestra il colore ''170'' per avvisare della
visualizzazione sbloccata.
> 'BLOCCATUTTE' la Visualizzazione di Tutte le Finestre del
disegno corrente ed applica alle finestre il colore ''DaLayer''.
> 'RUOTA' la Visualizzazione nella Finestra. Richiede la selezione
di due punti da assegnare come nuovo allineamento
orizzotale oppure digitazione di un angolo.
(0 ripristina l'angolo originale).
> 'CONGELA' i Layers selezionati nella Finestra.
> 'ISOLA' i Layers selezionati nella Finestra congelando gli altri.
> 'SCONGELA' Tutti i Layers nella Finestra selezionata.
> '?' Questa guida.

Angelo Stocco - Aprile 2016
"
)
)
(princ);_end
;;; --------------------------------------------------------------------------------- ;;;
;;; box messaggio tipo VB - WScript.Shell
;;; http://www.theswamp.org/index.php?topic=29537.0
;;; MsgBox (Patrick_35)
;;; --------------------------------------------------------------------------------- ;;;
;;;
;;; Val buttons
;;; 0 vlax-vbOKOnly
;;; 1 vlax-vbOKCancel
;;; 2 vlax-vbAbortRetryIgnore
;;; 3 vlax-vbYesNoCancel
;;; 4 vlax-vbYesNo
;;; 5 vlax-vbRetryCancel
;;; 16 vlax-vbKatakana
;;; 32 vlax-vbQuestion
;;; 48 vlax-vbExclamation
;;; 64 vlax-vbInformation
;;;
;;; Val return
;;; 1 OK
;;; 2 Cancel
;;; 3 Abort
;;; 4 Retry
;;; 5 Ignor
;;; 6 Yes
;;; 7 No

(defun MsgBox (title buttons message / return WshShell)
(setq WshShell (vlax-create-object "WScript.Shell"))
(setq return (vlax-invoke
WshShell
'Popup
message
0 ;time
title
(itoa buttons)
)
)
(vlax-release-object WshShell)
return
);_end MsgBox
;;; --------------------------------------------------------------------------------- ;;;

(vl-load-com)
(princ
(strcat
"\n\\U+00AB ViewPort Creator - CFL.lsp - April 2016 \\U+00BB"
"\n\\U+00AB comandi: \"CreaFinLay\" o \"CFL\", \"-GFL\", \"FLINFO\". \\U+00BB"
)
)
(princ)
(c:cfl)

Rotate North Arrow block in current layout


;;; Rotate North Arrow block in current layout
;;; Created by: dlanorh
;;; Slightly modified by Igal Averbuh 2018 (added refer to floating viewports)
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/rotating-object-using-two-parameters-north-arrow/td-p/8372595

(defun c:na( / c_doc a_units vt_ang ss)
(vl-load-com)
(command "._mspace")
(princ "\nYou must to be in a floating viewport to set North Arrow rotation angle...")
(setq c_doc (vla-get-activedocument(vlax-get-acad-object))
a_units (getvar 'aunits) ;gets the current angular units setting and stores it
);end_setq
(setvar 'aunits 3) ;sets angular units to radians
(setq vt_ang (getvar 'viewtwist)) ;gets viewtwist angle in radians
(setvar 'aunits a_units)

; FRMARROW it's a "North Arrow" block in drawing. (plase your north arrow block here)

(setq ss (ssget "X" (list '(2 . "FRMARROW") (cons 410 (getvar "ctab"))))) ;gets a selection set of "North Arrow" blocks in current layout

(vlax-for blk (vla-get-activeselectionset c_doc) ;gets the active selection set as a collection of objects and loop through
(if (vlax-property-available-p blk 'rotation T) ;if the object has a rotation property and it is writeable
(vlax-put-property blk 'rotation vt_ang) ;give the object (block) the rotation angle
);end_if
);end_for
(setq ss nil)
(command "._pspace")
(princ)
);end_defun
(c:na)

Draw Lighting Line with radial connection to Poles and option to “Unexlode” connected lines to Polyline


;;; Draw Lighting Line with radial connection to Poles and option to "Unexlode" connected lines to Polyline
;;; Based on CAB solution saved from: http://www.cadtutor.net/forum/showthread.php?36112-Electrical-Wiring-Lsp
;;; Combined with other subroutines and slightly modified by Igal Averbuh 2018 (added option to set radius of poles connection)

;;; Based on Lee Mak routines saved from: http://www.cadtutor.net/forum/showthread.php?92452-convert-lines-to-polyline-(where-endpoints-coincide)

;;--------------------=={ Chain Selection }==-----------------;;
;; ;;
;; Prompts the user to select an object and generates a ;;
;; selection chain of all objects sharing endpoints with ;;
;; objects in the accumulative selection. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:pj ( / *error* sel val var )

(defun *error* ( msg )
(mapcar '(lambda ( a b ) (if b (setvar a b))) var val)

(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(c:luo)
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel
(LM:ssget "\nPolyline was Unexploded "
'( "_:L"
(
(-4 . "<OR")
(0 . "LINE,ARC")
(-4 . "<AND")
(0 . "LWPOLYLINE")
(-4 . "")
(-4 . "AND>")
(-4 . "OR>")
)
)
)
)
(progn
(setq var '(cmdecho peditaccept)
val (mapcar 'getvar var)
)
(mapcar '(lambda ( a b c ) (if a (setvar b c))) val var '(0 1))
(command "_.pedit" "_m" sel "" "_j" "" "")
)
)
(*error* nil)
(princ)
)

(defun c:ccp ( / en fl in l1 l2 s1 s2 sf vl )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))

(setvar 'maxactvp 64)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
(setvar 'maxactvp 64)
)
(princ)
)

(setq sf
(list
'(-4 . "<OR")
'(0 . "LINE,ARC")
'(-4 . "<AND")
'(0 . "LWPOLYLINE,SPLINE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "<AND")
'(0 . "POLYLINE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "<AND")
'(0 . "ELLIPSE")
'(-4 . "<OR")
'(-4 . "")
'(41 . 0.0)
'(-4 . "")
(cons 42 (+ pi pi))
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
(if (setq s1 (ssget "_X" sf))
(if (setq en (ssget "_+.:E:S" sf))
(progn
(setq s2 (ssadd)
en (ssname en 0)
l1 (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en))
)
(repeat (setq in (sslength s1))
(setq en (ssname s1 (setq in (1- in)))
vl (cons (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en) en) vl)
)
)
(while
(progn
(foreach v vl
(if (vl-some '(lambda ( p ) (or (equal (car v) p 1e-8) (equal (cadr v) p 1e-8))) l1)
(setq s2 (ssadd (caddr v) s2)
l1 (vl-list* (car v) (cadr v) l1)
fl t
)
(setq l2 (cons v l2))
)
)
fl
)
(setq vl l2 l2 nil fl nil)
)
)
)
(princ "\nNo valid objects found.")
)
(sssetfirst nil s2)
(princ)
)
(vl-load-com) (princ)

(defun c:up ( / )
(princ "\nSelect Lighting Line to Join with other segments")
(c:ccp)
(c:pj)
)

;; Uniformly Scaled Block - Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
(if (vlax-property-available-p obj 'xeffectivescalefactor)
(setq s "effectivescalefactor")
(setq s "scalefactor")
)
(eval
(list 'defun 'LM:usblock-p '( obj )
(list 'and
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "y" s))
1e-8
)
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "z" s))
1e-8
)
)
)
)
(LM:usblock-p obj)
)

;; entlast - Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
(setq ent (entlast))
(while (setq tmp (entnext ent)) (setq ent tmp))
ent
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)

;;----------------------------------------------------------------------;;

(vl-load-com)

;; LayerIsolateOnOff.lsp [command names: LIO, LUO]
;; To Isolate and Unisolate only the On-Off condition of Layers of selected objects.
;; LIO isolates Layers of selected objects, leaving those Layers on and turning all
;; other Layers off that are not already off. If repeated before LUO turns those
;; Layers back on, makes further isolations, to as many levels as desired.
;; LUO turns latest set of turned-off Layers back on, without undoing other Layer
;; options that may have been used under isolated conditions [as happens with
;; some (e.g. colors) if using AutoCAD's standard LAYERUNISO to return to un-
;; isolated conditions after using LAYISO]. When repeated, steps back through
;; as many isolations as were done with LIO [LAYISO can only step back once].
;; Kent Cooper, August 2011

(vl-load-com)

(defun liV (sub); = build Variable name with subtype and current integer ending
(read (strcat "li" sub (itoa liinc)))
); defun

(defun liG (sub); = Get what's in the above variable
(eval (read (strcat "li" sub (itoa liinc))))
); defun

(defun C:LIO (/ ss cmde laysel layname lion layobj); = Layer Isolate -- On-Off condition only
(prompt "\nSelect Layers to remain ON,")
(if (setq ss (ssget)); object selection
(progn
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(repeat (sslength ss); make list of Layer names to remain on
(setq laysel (cdr (assoc 8 (entget (ssname ss 0))))); Layer name
(if (not (member laysel lion)) (setq lion (cons laysel lion))); add if not already there
(ssdel (ssname ss 0) ss)
); repeat
(setq liinc (if liinc (1+ liinc) 1)); liinc is global; 1 for first time, etc.
(if
(set (liV "cur"); global variable(s), but need(s) to be:
(if (not (member (getvar 'clayer) lion)); nil if current Layer kept on
(vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer)))
); if
); set
(setvar 'clayer (nth 0 lion)); then - make some selected object's Layer current
); if
(while (setq layname (cdadr (tblnext "layer" (not layname)))); step through Layers
(if
(and
(not (member layname lion)); not among selected objects' Layers
(> (cdr (assoc 62 (tblsearch "layer" layname))) 0); currently on
); and
(progn
(setq layobj (vlax-ename->vla-object (tblobjname "layer" layname)))
(set (liV "off") (cons layobj (liG "off")))
; put in list of Layers turned off -- makes global variables lioff1, lioff2, etc.
(vla-put-LayerOn layobj 0); turn off
); progn
); if
); while
(prompt
(strcat
"\n"
(itoa (length lion))
" Layer(s) isolated, "
(itoa (length (liG "off")))
" Layer(s) turned off."
(if (liG "cur")
(strcat " Layer " (getvar 'clayer) " has been made current."); then
"" ; else - add nothing to prompt if current Layer remains on
); if
); strcat
); prompt
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNothing selected.")
); if
(princ)
); defun

(defun C:LUO (/ cmde lugone lucur); = Layer Unisolate -- On-Off condition only
(if (> liinc 0); at least one list of turned-off Layers exists
(progn ; then
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(foreach lay (liG "off"); latest numbered list
(if (vlax-vla-object->ename lay); still in drawing
(vla-put-LayerOn lay -1); then - turn on
(progn ; else
(vl-remove lay (liG "off")); to adjust number for prompt later
(setq lugone (if lugone (1+ lugone) 1)); quantity of no-longer-present Layers
); progn
); if
); foreach
(if ; restore Layer current at time of corresponding LIO if it was turned off
(and
(liG "cur"); nil if it wasn't
(vlax-vla-object->ename (liG "cur")); Layer still in drawing, even if renamed
); and
(progn
(setq lucur (vla-get-Name (liG "cur"))); present name if renamed since its LIO
(setvar 'clayer lucur); restore as current
); progn
); if
(prompt
(strcat
"\n"
(itoa (length (liG "off")))
" Layer(s) turned back on."
(if (liG "cur") ; corresponding LIO turned off current Layer at the time
(strcat ; then
"\nLayer "
(if (vlax-vla-object->ename (liG "cur")); still in drawing
(vla-get-Name (liG "cur")); then - name, even if renamed
"current at time of LIO purged, and not"
); if
" restored as current."
); strcat
"" ; else - add nothing if corresponding LIO kept current Layer on
); if
(if lugone (strcat "\n" (itoa lugone) " purged Layer(s) not turned back on.") "")
); strcat
); prompt
(set (liV "off") nil); clear list ending with latest integer in use
(set (liV "cur") nil); clear current-at-LIO-Layer-if-changed value with latest integer
(setq liinc (1- liinc)); increment downward for next-earlier list
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNo Layers to Unisolate."); else
); if
(princ)
); defun

;; CAB 05.13.09
;; Draw Electric Wire
(defun c:ew (/ ew_layer p1 p2 msg height ang)
; (setvar 'filletrad 1)
(setvar 'filletrad
(cond ((getdist (strcat "\nSet wire radius : ")))
((getvar 'filletrad))
)
)
;(setq ew_layer (getvar "CLAYER")) ; set current layer
(command "Layer" "M" "EL-LT-CABL-160" "lt" "continuous" "" "c" "160" "" "")
(setq ew_layer "EL-LT-CABL-160") ; layer name
;(SETQ PINS (GETdist "\nSet wire radius "))
(setq height (GETdist "\nSet chamfer height: ")) ; set chamfer height
(setq ang 45) ; set chamfer angle

(defun draw-ew (p4 p1 lay / p2 p3)
(setq p2 (polar p1 (- (angle p1 p4) (/ (* ang pi) 180)) height)
p3 (polar p4 (+ (angle p4 p1) (/ (* ang pi) 180)) height)
)
(entmakex
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lay)
(cons 90 4)
'(70 . 0) ; 1 for closed 0 overwise
(cons 10 (trans p1 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 (trans p2 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 (trans p3 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 (trans p4 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
'(210 0.0 0.0 1.0)
)
)
)

(and
(setq p1 (getpoint "\nPick start point (Draw clockwise"))
(setq msg "\nPick next point clockwise.")
(while (setq p2 (getpoint p1 msg))
(command "_.fillet" "_P" (draw-ew p1 p2 ew_layer))
(setq p1 p2)
)
)
(princ)
)

(defun c:mf ( / )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
(c:luo)

(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))

)
(princ)
)

(c:ew)
(c:lio)
(c:up)
(c:luo)
)
(c:mf)

Draw Lighting Line with 45 degree connection to Poles and option to “Unexlode” connected lines to Polyline


;;; Draw Lighting Line with 45 degree connection to Poles and option to "Unexlode" connected lines to Polyline
;;; Based on CAB solution saved from: http://www.cadtutor.net/forum/showthread.php?36112-Electrical-Wiring-Lsp
;;; Combined with other subroutines and slightly modified by Igal Averbuh 2018 (added option to set set chamfer height for poles connection)

;;; Based on Lee Mak routines saved from: http://www.cadtutor.net/forum/showthread.php?92452-convert-lines-to-polyline-(where-endpoints-coincide)

;;--------------------=={ Chain Selection }==-----------------;;
;; ;;
;; Prompts the user to select an object and generates a ;;
;; selection chain of all objects sharing endpoints with ;;
;; objects in the accumulative selection. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:pj ( / *error* sel val var )

(defun *error* ( msg )
(mapcar '(lambda ( a b ) (if b (setvar a b))) var val)

(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(c:luo)
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel
(LM:ssget "\nPolyline was Unexploded "
'( "_:L"
(
(-4 . "<OR")
(0 . "LINE,ARC")
(-4 . "<AND")
(0 . "LWPOLYLINE")
(-4 . "")
(-4 . "AND>")
(-4 . "OR>")
)
)
)
)
(progn
(setq var '(cmdecho peditaccept)
val (mapcar 'getvar var)
)
(mapcar '(lambda ( a b c ) (if a (setvar b c))) val var '(0 1))
(command "_.pedit" "_m" sel "" "_j" "" "")
)
)
(*error* nil)
(princ)
)

(defun c:ccp ( / en fl in l1 l2 s1 s2 sf vl )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))

(setvar 'maxactvp 64)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
(setvar 'maxactvp 64)
)
(princ)
)

(setq sf
(list
'(-4 . "<OR")
'(0 . "LINE,ARC")
'(-4 . "<AND")
'(0 . "LWPOLYLINE,SPLINE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "<AND")
'(0 . "POLYLINE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "<AND")
'(0 . "ELLIPSE")
'(-4 . "<OR")
'(-4 . "")
'(41 . 0.0)
'(-4 . "")
(cons 42 (+ pi pi))
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
(if (setq s1 (ssget "_X" sf))
(if (setq en (ssget "_+.:E:S" sf))
(progn
(setq s2 (ssadd)
en (ssname en 0)
l1 (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en))
)
(repeat (setq in (sslength s1))
(setq en (ssname s1 (setq in (1- in)))
vl (cons (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en) en) vl)
)
)
(while
(progn
(foreach v vl
(if (vl-some '(lambda ( p ) (or (equal (car v) p 1e-8) (equal (cadr v) p 1e-8))) l1)
(setq s2 (ssadd (caddr v) s2)
l1 (vl-list* (car v) (cadr v) l1)
fl t
)
(setq l2 (cons v l2))
)
)
fl
)
(setq vl l2 l2 nil fl nil)
)
)
)
(princ "\nNo valid objects found.")
)
(sssetfirst nil s2)
(princ)
)
(vl-load-com) (princ)

(defun c:up ( / )
(princ "\nSelect Lighting Line to Join with other segments")
(c:ccp)
(c:pj)
)

;; Uniformly Scaled Block - Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
(if (vlax-property-available-p obj 'xeffectivescalefactor)
(setq s "effectivescalefactor")
(setq s "scalefactor")
)
(eval
(list 'defun 'LM:usblock-p '( obj )
(list 'and
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "y" s))
1e-8
)
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "z" s))
1e-8
)
)
)
)
(LM:usblock-p obj)
)

;; entlast - Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
(setq ent (entlast))
(while (setq tmp (entnext ent)) (setq ent tmp))
ent
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)

;;----------------------------------------------------------------------;;

(vl-load-com)

;; LayerIsolateOnOff.lsp [command names: LIO, LUO]
;; To Isolate and Unisolate only the On-Off condition of Layers of selected objects.
;; LIO isolates Layers of selected objects, leaving those Layers on and turning all
;; other Layers off that are not already off. If repeated before LUO turns those
;; Layers back on, makes further isolations, to as many levels as desired.
;; LUO turns latest set of turned-off Layers back on, without undoing other Layer
;; options that may have been used under isolated conditions [as happens with
;; some (e.g. colors) if using AutoCAD's standard LAYERUNISO to return to un-
;; isolated conditions after using LAYISO]. When repeated, steps back through
;; as many isolations as were done with LIO [LAYISO can only step back once].
;; Kent Cooper, August 2011

(vl-load-com)

(defun liV (sub); = build Variable name with subtype and current integer ending
(read (strcat "li" sub (itoa liinc)))
); defun

(defun liG (sub); = Get what's in the above variable
(eval (read (strcat "li" sub (itoa liinc))))
); defun

(defun C:LIO (/ ss cmde laysel layname lion layobj); = Layer Isolate -- On-Off condition only
(prompt "\nSelect Layers to remain ON,")
(if (setq ss (ssget)); object selection
(progn
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(repeat (sslength ss); make list of Layer names to remain on
(setq laysel (cdr (assoc 8 (entget (ssname ss 0))))); Layer name
(if (not (member laysel lion)) (setq lion (cons laysel lion))); add if not already there
(ssdel (ssname ss 0) ss)
); repeat
(setq liinc (if liinc (1+ liinc) 1)); liinc is global; 1 for first time, etc.
(if
(set (liV "cur"); global variable(s), but need(s) to be:
(if (not (member (getvar 'clayer) lion)); nil if current Layer kept on
(vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer)))
); if
); set
(setvar 'clayer (nth 0 lion)); then - make some selected object's Layer current
); if
(while (setq layname (cdadr (tblnext "layer" (not layname)))); step through Layers
(if
(and
(not (member layname lion)); not among selected objects' Layers
(> (cdr (assoc 62 (tblsearch "layer" layname))) 0); currently on
); and
(progn
(setq layobj (vlax-ename->vla-object (tblobjname "layer" layname)))
(set (liV "off") (cons layobj (liG "off")))
; put in list of Layers turned off -- makes global variables lioff1, lioff2, etc.
(vla-put-LayerOn layobj 0); turn off
); progn
); if
); while
(prompt
(strcat
"\n"
(itoa (length lion))
" Layer(s) isolated, "
(itoa (length (liG "off")))
" Layer(s) turned off."
(if (liG "cur")
(strcat " Layer " (getvar 'clayer) " has been made current."); then
"" ; else - add nothing to prompt if current Layer remains on
); if
); strcat
); prompt
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNothing selected.")
); if
(princ)
); defun

(defun C:LUO (/ cmde lugone lucur); = Layer Unisolate -- On-Off condition only
(if (> liinc 0); at least one list of turned-off Layers exists
(progn ; then
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(foreach lay (liG "off"); latest numbered list
(if (vlax-vla-object->ename lay); still in drawing
(vla-put-LayerOn lay -1); then - turn on
(progn ; else
(vl-remove lay (liG "off")); to adjust number for prompt later
(setq lugone (if lugone (1+ lugone) 1)); quantity of no-longer-present Layers
); progn
); if
); foreach
(if ; restore Layer current at time of corresponding LIO if it was turned off
(and
(liG "cur"); nil if it wasn't
(vlax-vla-object->ename (liG "cur")); Layer still in drawing, even if renamed
); and
(progn
(setq lucur (vla-get-Name (liG "cur"))); present name if renamed since its LIO
(setvar 'clayer lucur); restore as current
); progn
); if
(prompt
(strcat
"\n"
(itoa (length (liG "off")))
" Layer(s) turned back on."
(if (liG "cur") ; corresponding LIO turned off current Layer at the time
(strcat ; then
"\nLayer "
(if (vlax-vla-object->ename (liG "cur")); still in drawing
(vla-get-Name (liG "cur")); then - name, even if renamed
"current at time of LIO purged, and not"
); if
" restored as current."
); strcat
"" ; else - add nothing if corresponding LIO kept current Layer on
); if
(if lugone (strcat "\n" (itoa lugone) " purged Layer(s) not turned back on.") "")
); strcat
); prompt
(set (liV "off") nil); clear list ending with latest integer in use
(set (liV "cur") nil); clear current-at-LIO-Layer-if-changed value with latest integer
(setq liinc (1- liinc)); increment downward for next-earlier list
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNo Layers to Unisolate."); else
); if
(princ)
); defun

;; CAB 05.13.09
;; Draw 45 degree connection
(defun c:ew (/ ew_layer p1 p2 msg height ang)
;(setq ew_layer (getvar "CLAYER")) ; set current layer
(command "Layer" "M" "EL-LT-CABL-160" "lt" "continuous" "" "c" "160" "" "")
(setq ew_layer "EL-LT-CABL-160") ; layer name
;(SETQ PINS (GETdist "\nSet wire radius "))
(setq height (GETdist "\nSet chamfer height: ")) ; set chamfer height
(setq ang 45) ; set chamfer angle

(defun draw-ew (p4 p1 lay / p2 p3)
(setq p2 (polar p1 (- (angle p1 p4) (/ (* ang pi) 180)) height)
p3 (polar p4 (+ (angle p4 p1) (/ (* ang pi) 180)) height)
)
(entmakex
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lay)
(cons 90 4)
'(70 . 0) ; 1 for closed 0 overwise
(cons 10 (trans p1 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 (trans p2 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 (trans p3 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 (trans p4 1 0))
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
'(210 0.0 0.0 1.0)
)
)
)

(and
(setq p1 (getpoint "\nPick start point (Draw clockwise"))
(setq msg "\nPick next point clockwise.")
(while (setq p2 (getpoint p1 msg))
(draw-ew p1 p2 ew_layer)
(setq p1 p2)
)
)
(princ)

)

(defun c:mc ( / )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
(c:luo)

(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))

)
(princ)
)

(c:ew)
(c:lio)
(c:up)
(c:luo)
)
;(c:mc)