Ademas de algún articulo entretenido, curiosidades y alguna que otra cosa del mundo del CAD, a partir de este momento publicaré algunos programas y utilidades programadas en AutoLisp, VisualLisp, NET, VBA o ARX.
AutoLisp y VisualLisp
van cogidos de la mano. Nos referiremos a ellos a partir de ahora siempre como VisualLisp.Este lenguaje de programación es originario de Autodesk, pero lo utilizan muchos programas del mundo del CAD como BrisCad, ZWCad y otros.
No es un lenguaje potente y un poco engorroso, hay una frase que se refiere a la programación en LISP como "Los estúpidos paréntesis", pero existen miles (por no decir millones) de programas y programadores en este lenguaje que en foros, webs y redes sociales nos pueden ayudar en nuestro trabajo y a programar nosotros mismos algunas utilidades que necesitemos.
Para los que se quieran iniciar en el mundillo de la programación en VisualLisp yo les recomiendo que busquen por la Web, hay infinidad de paginas con tutoriales y programas de ejemplo. Algunos ejemplos de sitios:
Después de todo esto seguimos un poco con el tema del blog (que me pierdo).
Existen funciones auxiliares que se utilizan constante y repetidamente en muchos programas realizados en VisualLisp. Por ejemplo una función para cambiar el color de una entidad, o para cambiar la capa, o el tipo de línea. Para los que ya conocéis el lenguaje ya sabéis a lo que me refiero. Normalmente tenemos estas funciones en un archivo independiente como por ejemplo:MisFuncionesAuxiliares.lsp
Este archivo normalmente se carga antes que el resto de archivos y la carga se puede hacer manual (no es muy recomendable por tener que cargarlo en cada sesión), por archivo de menu (mnl), por medio de archivo acaddoc.lsp o por alguna rutina autoload.
Los programas, rutinas o funciones que publicaré necesitarán de estas funciones y voy a dejar aqui para su descarga la primera versión para utilizarla con estos.
El archivo se ira modificando y creciendo a medida que publique mas programas, iré informando sobre ello en cada publicación.
Descarga y codigo:
Select all
;;;--------------------------------------------------------;;
;;; ;;
;;; | _ |\/| _ _ _ .|_ _ ;;
;;; |__(_| | |(_|| |||||_(_| ;;
;;; ;;
;;;--------------------------------------------------------;;
;;NOTAS: ;;
;;CABECERAS: ASCII Generator, tipo: straight ;;
;;http://www.network-science.de/ascii/ ;;
;;---------------------------------------------------------;;
;;------------------- DEFAULTS ------------------------------
;; Valores por defecto al cargar el programa
;;-----------------------------------------------------------
;;Variables GLOBALES
(setq **NameJLGGGlobal** "LaMarmita")
(setq **NameJLGGPopMenu** "LaMarmita")
;;(setq **NameJLGGMenu** "LAMARMITA" ) ;;en MNL
(setq **NameJLGGVersion** "LaMarmita.2018")
;;___________________________________________________________
(vl-doc-set '**NameJLGGGlobal** **NameJLGGGlobal** )
(vl-doc-set '**NameJLGGPopMenu** **NameJLGGPopMenu**)
;;(vl-doc-set '**NameJLGGMenu** **NameJLGGMenu** ) ;;en MNL
(vl-doc-set '**NameJLGGVersion** **NameJLGGVersion**)
;;____________________________________________
;;Activar AutoCAD-Vlisp ActiveX
(vl-load-com)
;;; __ __ __ __ __ __ ;;;
;;; / _ |_ |\ ||_ |__) /\ | |_ (_ ;;;
;;; \__)|__| \||__| \ /--\|__|____) ;;;
;;; ;;;
;;------------------ jlgg-UndoStart --------------------
;; (COMMAND "_.undo" "_be") con VLA
;; Uso: (jlgg-UndoStart (jlgg-ActDoc))
;;------------------------------------------------------
(defun jlgg-UndoStart (doc)
(jlgg-UndoEnd doc)
(vla-startundomark doc)
)
;;------------------ jlgg-UndoEnd ----------------------
;; (COMMAND "_.undo" "_e") con VLA
;; Uso: (jlgg-UndoEnd (jlgg-ActDoc))
;;------------------------------------------------------
(defun jlgg-UndoEnd (doc)
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;;-------------------------------- jlgg-ActDoc --------------------------------------
;; Devuelve el objeto VLA del documento activo
;;-----------------------------------------------------------------------------------
;;(defun jlgg-ActDoc () (vla-get-activedocument (vlax-get-acad-object)))
(defun jlgg-ActDoc ()
(vla-get-activedocument (vlax-get-acad-object))
)
;;---------------------------- jlgg-Get-ActiveSpace ---------------------------------
;; Obtener el Espacio activo de un documento
;;-----------------------------------------------------------------------------------
(defun jlgg-Get-ActiveSpace (*AcDoc*)
(if (not *AcDoc*)(setq *AcDoc* (jlgg-ActDoc)))
(vlax-get-property *AcDoc* (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
);c.defun
;;; __ __ __ __ __ ;;;
;;; |_ |__)|__)/ \|__) ;;;
;;; |__| \ | \ \__/| \ ;;;
;;; ;;;
;;******************************************************************************************;;
;; RUTINA GENERAL DE ERROR ;;
;;---------------------------------- LMT:error ---------------------------------------------;;
;; Función para manejo de errores, Rutina general de error que sustituye ;;
;; a la funcion de *error* de Autocad para nuestros programas. ;;
;; Esta rutina sirve para cargarla con casi todos los programas. Modo de uso: ;;
;; Modo de uso: ;;
;; Inicio Prg: (setq ac:err *error* *error* LMT:error) ;;
;; Fin Prg: (setq *error* ac:err ac:err nil) ;;
;;------------------------------------------------------------------------------------------;;
(defun LMT:error (msg / funC sTmp)
;; Utilizar "command-s" en versiones superiores para no tener problemas
;;(setq funC (if (>= (read (substr (getvar "ACADVER") 1 4)) 20) command-s vl-cmdf))
;;____________________________________________________________________________________
;; (command-s) por si solo no cancela comandos y (command) o (vl-cmdf) si los cancela
;; pero estos dos últimos pueden causar problemas en las nuevas versiones de Autocad
;; (2015 - 2016) dentro de la funcion de error.
;;(while (/= (getvar "CMDNAMES") "") (funC)) ;;cancelar comandos activos
;;Uso (jlgg_cancelcmd) del ARX en su lugar (Aún no implementado para LA MARMITA)
;;(repeat 2 (jlgg_cancelcmd)) ;;cancelar comandos activos
;;__________________________________________________________________________
;;RESTABLECEMOS UNDOs NO TERMINADOS..
(jlgg-UndoEnd (jlgg-ActDoc))
;;Mensaje:
(if (not (setq sTmp (vl-doc-ref '*NameAppRun*)))
(setq sTmp "LaMarmitaApp")
)
(vl-doc-set '*NameAppRun* nil)
(if msg
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*,interrup*")))
(princ (strcat "\nError en " sTmp ": " msg))
)
)
;;Si existio error en APP: devolvemos a Autocad su función de ERROR
;;; (if ac:err
;;; (setq *error* ac:err ac:err nil)
;;; )
;;si existio error y las variables no se guardarón se restablecen como estaban
(jlgg-res_vars)
;;para que no exista conflicto con la proxima app en ejecución
(vl-doc-set '*Tmp_ListVars* nil)
(princ)
);cierro defun
;;; __ __ __ __ __ __ ;;;
;;; / / \| / \|__)|_ (_ ;;;
;;; \__\__/|__\__/| \ |____) ;;;
;;; ;;;
;;--------------------------- jlgg-Get_Col ------------------
;;obtener lista de color de una entidad
(defun jlgg-Get_Col (obj / tmpCol)
(setq obj (jlgg-GetENAM-Obj obj))
(if (null (setq tmpCol (vl-remove-if-not
(function (lambda (x) (Member (car x) '(62 420 430))))
(entget Obj))))
(setq tmpCol '((62 . 256))))
tmpCol
);c.defun
;-------------------- cambio de color de una entidad ---------------------
(defun jlgg-Ch_Col (Ent listCol / tmpCol LEnt)
(setq Ent (jlgg-GetENAM-Obj Ent))
(cond ((= (type listCol) 'INT)
(if (> listCol 256)
(setq tmpCol (list '(62 . 7) (cons 420 listCol))) ;420 = OLECOLOR
(setq tmpCol (list (cons 62 listCol))))) ;62 = ACI color
((= (type listCol) 'LIST)
(setq tmpCol listCol))
);c.cond
(if tmpCol
(setq LEnt (vl-remove-if
(function (lambda (x) (Member (car x) '(62 420 430)))) ;62 = ACI color, 420 = OLECOLOR, 430 = color de Libros de color
(entget Ent))
LEnt (append LEnt tmpCol)
LEnt (entmod LEnt))
);c.if
);c.defun
(defun jlgg-Set_Col (Ent listCol)(jlgg-Ch_Col Ent listCol))
;;------------------------------ RGB & ACI -----------------------------------
;; RGB -> ACI - Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values
(defun RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
;; ACI -> RGB - Lee Mac
;; Args: c - [int] ACI (AutoCAD Colour Index) Colour (1<=c<=255)
(defun ACI->RGB ( c / o r )
(if (setq o (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq r
(vl-catch-all-apply
'(lambda ( )
(vla-put-colorindex o c)
(list (vla-get-red o) (vla-get-green o) (vla-get-blue o))
)
)
)
(vlax-release-object o)
(if (vl-catch-all-error-p r)
(prompt (strcat "\nError: " (vl-catch-all-error-message r)))
r
)
)
)
)
;;------------------------------ True & ACI -----------------------------------
;; True -> ACI - Lee Mac
;; Args: c - [int] True Colour
(defun True->ACI ( c / o r )
(apply 'RGB->ACI (True->RGB c))
)
;; ACI -> True - Lee Mac
;; Args: c - [int] ACI (AutoCAD Colour Index) Colour (1<=c<=255)
(defun ACI->True ( c / o r )
(apply 'RGB->True (ACI->RGB c))
)
;;------------------------------ RGB & True -----------------------------------
;; RGB -> True - Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values
(defun RGB->True ( r g b )
(logior (lsh (fix r) 16) (lsh (fix g) 8) (fix b))
)
;; True -> RGB - Lee Mac
;; Args: c - [int] True Colour
(defun True->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
)
;; RGB -> OLE - Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values
(defun RGB->OLE ( r g b )
(logior (fix r) (lsh (fix g) 8) (lsh (fix b) 16))
)
;; OLE -> RGB - Lee Mac
;; Args: c - [int] OLE Colour
(defun OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
;;Nombre de color
;Argumento LCol= Lista, Numero o Cadena
(defun jlgg-NameCol (LCol / TmpCol )
(defun GetStrRGB (NumTrueColor / StrCol RGB)
(setq RGB (True->RGB NumTrueColor)
StrCol (strcat "R:" (itoa (car RGB)) ",G:" (itoa (cadr RGB)) ",B:" (itoa (last RGB))))
);c.defun
;;-------- MAIN ----------------------
(if (= (type LCol) 'LIST)
(progn
(setq TmpCol (cdr (nth (1- (length LCol)) LCol)))
(cond
((= (length LCol) 3)
(setq LCol (last (str2lst TmpCol "$")))
)
((= (length LCol) 2)
(setq LCol (GetStrRGB TmpCol))
)
(T (setq LCol TmpCol))
);c.cond
);c.prg
);c.if
(Setq LCol
(cond
((member (type LCol) (list 'REAL 'INT))
(cond ((= LCol 0) "PorBloque")
((= LCol 1) "Rojo")
((= LCol 2) "Amarillo")
((= LCol 3) "Verde")
((= LCol 4) "Ciano")
((= LCol 5) "Azul")
((= LCol 6) "Magenta")
((= LCol 7) "Blanco")
((= LCol 256) "PorCapa")
(t
(if (> LCol 256)
(GetStrRGB LCol)
(jlgg-rtos LCol 2 0)
)
)
)
)
((= (type LCol) 'STR) LCol)
(T nil)
);c.cond
);c.setq
);c.defun
;;; __ __ __ ;;;
;;; / /\ |__) /\ (_ ;;;
;;; \__/--\| /--\__) ;;;
;;; ;;;
;-------------------------- jlgg-GetOrNewLayer ---------------------------
; Obtener o crear una capa por su nombre
;-------------------------------------------------------------------------
(defun jlgg-GetOrNewLayer (LayerName)
(vla-add
(vla-get-layers
(jlgg-ActDoc)) LayerName)
)
;-------------------------- jlgg-Chg_Cap ---------------------------------
; cambiar la capa de una entidad (ENAME o VLA-OBJECT)
;-------------------------------------------------------------------------
(defun jlgg-Chg_Cap (ent LayerName / )
(jlgg-GetOrNewLayer LayerName)
(vla-put-Layer (jlgg-GetVLA-Obj ent) LayerName)
)
;; *********************FIN - FUNCIONES DE CAPAS *************************
;;; __ __ __ _____ __ __ ;;;
;;; |__)|_ / _ |(_ | |__)/ \ ;;;
;;; | \ |__\__)|__) | | \ \__/ ;;;
;;; ;;;
(defun jlgg-LispApps-product-key (/ Comun)
(setq Comun "HKEY_CURRENT_USER\\SOFTWARE\\")
(cond
((and (vl-doc-ref '**NameJLGGGlobal**) (vl-doc-ref '**NameJLGGVersion**))
(strcat Comun (vl-doc-ref '**NameJLGGGlobal**) "\\" (vl-doc-ref '**NameJLGGVersion**) "\\")
)
( **NameJLGGVersion**
(strcat Comun (vl-doc-ref '**NameJLGGVersion**) "\\")
)
(T Comun)
);c.cond
)
;;___________________________________________________________________
(DEFUN jlgg-List-Registry-Command (NameApp Valores?)
(if NameApp
(if Valores?
(vl-registry-descendents (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp) "*") ;Valores
(vl-registry-descendents (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp)) ;subdir
);c.if
(if Valores?
(vl-registry-descendents (jlgg-LispApps-product-key) "*") ;Valores
(vl-registry-descendents (jlgg-LispApps-product-key)) ;Subdir
);c.if
);c.if
);c.defun
;;___________________________________________________________________
(DEFUN jlgg-Delete-Registry-Command (NameApp Key)
(cond
((and NameApp Key)
(vl-registry-delete (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp) key))
(key
(vl-registry-delete (jlgg-LispApps-product-key) key))
(NameApp
(vl-registry-delete (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp)))
);c.cond
);c.defun
;;___________________________________________________________________
(DEFUN jlgg-Read-Registry-Command (NameApp Key)
(cond
((and NameApp Key)
(vl-registry-read (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp) key))
((and key)
(vl-registry-read (jlgg-LispApps-product-key) key))
);c.cond
);c.defun
;;___________________________________________________________________
(DEFUN jlgg-Write-Registry-Command (NameApp Key Value)
(cond
((and NameApp Key Value)
(vl-registry-write (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp) key Value))
((and Key Value)
(vl-registry-write (jlgg-LispApps-product-key) Key Value))
((and NameApp (null Key) (null Value))
(vl-registry-write (strcat (jlgg-LispApps-product-key) ;|"\\"|; NameApp)))
);c.cond
);c.defun
;;--------------------------------- jlgg-GetVal_Reg_Command ---------------------------------------
;; Datos de usuario obtenidos y guardados en el registro de Windows
;; Ejemplo: (setq RetVal (jlgg-GetVal_Reg_Command LisVal "RotCarp"))
;;-------------------------------------------------------------------------------------------------
(defun jlgg-GetVal_Reg_Command (LisVal sCommand / RetVal)
(setq RetVal
(mapcar (function (lambda (key-val)
(if (caddr key-val) ;;Force Write registry
(progn
(jlgg-Write-Registry-Command sCommand (car key-val) (cadr key-val))
(list (car key-val) (cadr key-val))
);c.prg
;;else
(if (setq ValTmp (jlgg-Read-Registry-Command sCommand (car key-val)))
(list (car key-val) ValTmp)
(progn
(jlgg-Write-Registry-Command sCommand (car key-val) (cadr key-val))
key-val
)
);c.if
);c.if
)) LisVal);c.mapcar
);c.setq
);c.defun
;;; ___ __ __ ;;;
;;; / \ | || |_ (_ ;;;
;;; \__/ | ||__|____) ;;;
;;; ;;;
(defun IsBricsCAD ()
(vl-string-search "BRICSCAD" (strcase (getvar 'acadver)))
)
;------------------------------ jlgg-dxf ---------------------------------
(defun jlgg-dxf (code elist) (cdr (assoc code elist)))
;;----------------------- jlgg-GetBlockName ------------------------------
;; Nombre real de un Bloque
;;------------------------------------------------------------------------
(defun jlgg-GetBlockName (obj)
(setq obj (jlgg-GetVLA-Obj obj))
(if (= (vla-get-ObjectName obj) "AcDbBlockReference")
(vlax-get-property obj
(if (vlax-property-available-p obj 'EffectiveName)
'EffectiveName 'Name
)
)
);c.if
)
;;----------------- jlgg-SSToList --------------------------
;; conjunto de seleccion a lista de entidades
;;----------------------------------------------------------
;;Antiguo:
(defun jlgg-SSToList (ss / ssl n)
(if (and ss (= (type ss) 'PICKSET))
(repeat (setq n (sslength ss))
(setq ssl (cons (ssname ss (setq n (1- n))) ssl))))
);c.defun
;;Nuevo:
(defun jlgg-SSToList (ss)
(if (and ss (= (type ss) 'PICKSET))
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
nil
)
);c.defun
;;------------------------- jlgg-ListToSS --------------------------------
;; lista de entidades (ENAMEs o VLA-OBJECTs) a conjunto de seleccion
;;------------------------------------------------------------------------
(defun jlgg-ListToSS (ListEnt / ssA)
(setq ssA (ssadd))
(cond
((and ListEnt
(= (type ListEnt) 'LIST))
(setq ListEnt (vl-remove-if 'NULL
(mapcar (function jlgg-GetENAM-Obj) ListEnt)))
(mapcar (function (lambda (ent) (setq ssA (ssadd ent ssA)))) ListEnt)
)
);c.cond
ssA
);c.defun
;;------------------------- jlgg-GetVLA-Obj ------------------------------
;;Obtiene la identidad de un objeto como VLA-OBJECT
;;------------------------------------------------------------------------
(defun jlgg-GetVLA-Obj (Entity / )
(cond
((= (Type Entity) 'ENAME) (vlax-ename->vla-object Entity))
((= (Type Entity) 'VLA-OBJECT) Entity)
(T nil)
)
)
;;------------------------- jlgg-GetENAM-Obj -----------------------------
;;Obtiene la identidad de un objeto como ENAME
;;------------------------------------------------------------------------
(defun jlgg-GetENAM-Obj (Entity / )
(cond
((= (Type Entity) 'VLA-OBJECT) (vlax-vla-object->ename Entity))
((= (Type Entity) 'ENAME) Entity)
(T nil)
)
)
;;-------------------- jlgg-release-object ------------------------------
;; release object o multiple releaseobject
;; (jlgg-release-object oVLA-OBJECT)
;; (jlgg-release-object (list oVLA-OBJECT1 oVLA-OBJECT2 .. oVLA-OBJECTn)
;;-----------------------------------------------------------------------
(defun jlgg-release-object (ListObj / )
(if (/= (type ListObj) 'LIST)
(setq ListObj (list ListObj))
)
(mapcar
(function
(lambda (obj)
(cond
(obj
(vl-catch-all-apply 'vlax-release-object (list obj))
)
)
)
)
ListObj
)
)
;;------------------------ OpenDrawingDBX ------------------------------------------
;; Abrir un archivo de Autocad sín necesidad de abrirlo en Autocad
;; Carga de la intrfaz y comprobaciones de apertura
;; Ejemplo: (setq a (OpenDrawingDBX "E:\\PROGRAMACION\\UTAS\\Ejemplo_UTA1.dbx"))
;; devuelve: #
;;----------------------------------------------------------------------------------
(defun OpenDrawingDBX (filename / FullPathFile checkFile ObjDbx release)
(cond
((or (not filename)
(/= (type filename) 'STR))
(alert "ERROR:\nArgumento para la ruta de archivo No Valido.")
)
((not (setq FullPathFile (findfile filename)))
(alert
(strcat "El Archivo de Datos: \n[ " filename " ]"
"\n\n No se encontro."
" Compruebe la ruta del archivo."))
)
;;Comprobamos la carga de la interfaz
((not
(vl-catch-all-apply (function (lambda ()
;;Obtención de la Interfaz del Objeto: ObjectDBX
(setq ObjDbx (vlax-create-object
(if (< (setq release (atoi (getvar "ACADVER"))) 16)
"ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa release)))))))))
(alert
(strcat "No se pudo obtener la interfaz de [ObjectDBX]"
"\nConsulte al programador."))
(jlgg-release-object (list ObjDbx))
(setq ObjDbx nil)
)
;; el archivo esta abierto por otro usuario (solo lectura) o esta dañado
((vl-catch-all-error-p
(vl-catch-all-apply 'vla-open (list ObjDbx FullPathFile)))
(alert
(strcat "El Archivo de Datos: "
(vl-filename-base FullPathFile) (vl-filename-extension FullPathFile) "\n"
"\n No se pudo abrir para su uso."
"\n Compruebe si el archivo esta en uso o dañado."
"\n Despues, Pruebe a ejecutar el comando de nuevo."))
(jlgg-release-object (list ObjDbx))
(setq ObjDbx nil)
)
)
ObjDbx
);c.defun
;;; ========== valor de osmode para pasarlo a initvars ==================
;;;
;;;(setvar "OSMODE" (boole 7 (getvar "OSMODE") 16384))
;;;Turns running object snap off
;;;(setvar "OSMODE" (boole 2 (getvar "OSMODE") 16384))
;;;Turns running object snap on
;;;
;;usar: (BtnRefent T) => Activar Boton Refent
;;usar: (BtnRefent nil) => Desactivar Boton Refent
(defun BtnRefent (Activate)
(setvar "OSMODE"
(boole (if Activate 2 7)
(getvar "OSMODE")
16384))
)
;;Funcion para usar con Initvars y ResVars
(defun osmodeOFF()
(if (null (= 16384 (logand 16384 (getvar "OSMODE"))))
(+ (getvar "OSMODE") 16384)
(getvar "OSMODE"))
);c.defun
;;;-------------------- jlgg-Init_Vars --------------------------------
;;; Inicializa variables
;;;--------------------------------------------------------------------
(defun jlgg-Init_Vars (ListVarTmp / j $list_vars$)
(setq $list_vars$ nil)
(if (= (type ListVarTmp) 'LIST)
(mapcar (function (lambda (lVar)
(if (getvar (car lVar))
(progn
(setq $list_vars$ (cons (list (car lVar) (getvar (car lVar))) $list_vars$))
;;(setvar (car lVar) (last lVar))
(vl-catch-all-apply (function setvar) (list (car lVar) (last lVar)))
);c.prg
);c.fi
)) ListVarTmp)
);c.if
(vl-doc-set '*Tmp_ListVars* $list_vars$)
);c.defun
;;;-------------------- jlgg-Res_Vars ---------------------------------
;;; restaura variables
;;;--------------------------------------------------------------------
(defun jlgg-Res_Vars ( / j $list_vars$)
(if (setq $list_vars$ (vl-doc-ref '*Tmp_ListVars*))
(mapcar (function (lambda (j)
(vl-catch-all-apply (function setvar) (list (car j) (last j)))
;;(setvar (car j) (last j))
)) $list_vars$)
);c.if
(vl-doc-set '*Tmp_ListVars* nil)
);c.defun
;;;--------------------------- jlgg-aux_tabla ----------------------------------
;;; (jlgg-aux_tabla )
;;;
;;; Returns a list of items in the specified table. The bit values have the
;;; following meaning:
;;; 0 List all items in the specified table.
;;; 1 Do not list Layer 0 and Linetype CONTINUOUS.
;;; 2 Do not list anonymous blocks or anonymous groups.
;;; A check against the 70 flag for the following bit:
;;; 1 anonymous block/group
;;; 4 Do not list externally dependant items.
;;; A check against the 70 flag is made for any of the following
;;; bits, which add up to 48:
;;; 16 externally dependant
;;; 32 resolved external or dependant
;;; 8 Do not list Xrefs.
;;; A check against the 70 flag for the following bit:
;;; 4 external reference
;;; 16 Add BYBLOCK and BYLAYER items to list.
;;;-----------------------------------------------------------------------------
(defun jlgg-aux_tabla (table_name bit / tbldata table_list just_name)
(setq tbldata nil)
(setq table_list '())
(setq table_name (xstrcase table_name))
(while (setq tbldata (tblnext table_name (not tbldata)))
(setq just_name (cdr (assoc 2 tbldata)))
(cond
((= "" just_name)) ; Never return null Shape names.
((and (= 1 (logand bit 1))
(or (and (= table_name "LAYER") (= just_name "0"))
(and (= table_name "LAYER") (= (strcase just_name) "DEFPOINTS"))
(and (= table_name "LTYPE")
(= (strcase just_name) "CONTINUOUS")
)
)
))
((and (= 2 (logand bit 2))
(= table_name "BLOCK")
(= 1 (logand 1 (cdr (assoc 70 tbldata))))
))
((and (= 4 (logand bit 4))
;; Check for Xref dependents only.
(zerop (logand 4 (cdr (assoc 70 tbldata))))
(not (zerop (logand 48 (cdr (assoc 70 tbldata)))))
))
((and (= 8 (logand bit 8))
(not (zerop (logand 4 (cdr (assoc 70 tbldata)))))
))
;; Vports tables can have similar names, only display one.
((member just_name table_list)
)
(T (setq table_list (cons just_name table_list)))
)
)
(cond
((and (= 16 (logand bit 16))
(= table_name "LTYPE") ) (setq table_list (cons "BYBLOCK"
(cons "BYLAYER" table_list))) )
(t)
)
(setq table_list table_list)
);c.defun
;;------------------------------------------------------------
; jlgg-grdx - graphic cross utility
(defun jlgg-grdx (p col size / h)
(setq h (/ (getvar "viewsize") size))
(grdraw (list (- (car p) h) (- (cadr p) h))
(list (+ (car p) h) (+ (cadr p) h)) col 0)
(grdraw (list (- (car p) h) (+ (cadr p) h))
(list (+ (car p) h) (- (cadr p) h)) col 0)
p
);c.defun
;;; __ __ __ _____ __ ;;;
;;; / _ |_ / \|\/||_ | |__)| /\ ;;;
;;; \__)|__\__/| ||__ | | \ |/--\ ;;;
;;; ;;;
;;***************************** WCS, UCS, OCS ****************************
;; transformacion de Angulos, y coordenadas en los sistemas de coordenadas
;;************************************************************************
;;------------------------------ UcsChgOrg ----------------------------
;;; Obtiene el Objeto ucs activo si este tiene nombre
;;---------------------------------------------------------------------
(defun GetActiveUCSObj ()
(cond
((= (getvar 'WORLDUCS) 1) "*WORLD*") ;; "*UNIVERSAL*")
((= (getvar 'UCSNAME) "") "*UNNAMED*")
((vla-get-ActiveUCS (jlgg-ActDoc)))
)
)
;;------------------------------ UcsChgOrg ----------------------------
;;; El nombre del ucs activo y sus datos
;;---------------------------------------------------------------------
(defun GetActiveUCS ( / dataUCS nameUCS)
(setq dataUCS (list (getvar "ucsorg")
(getvar "ucsxdir")
(getvar "ucsydir")))
(cond
((= (getvar 'WORLDUCS) 1) ;;"*WORLD*" ;"*UNIVERSAL*"
(setq dataUCS (cons "*WORLD*" dataUCS))
)
((= (setq nameUCS (getvar 'UCSNAME)) "")
(setq dataUCS (cons "*UNNAMED*" dataUCS))
)
(T ;;Ucs con nombre
(setq dataUCS (cons nameUCS dataUCS))
;(setq dataUCS (append dataUCS (list (vla-get-ActiveUCS (jlgg-ActDoc)))))
)
)
)
;;-------------------------------- UscGetOrSet -------------------------------
;;;Parametros :-
;;; NewUcsName :
;;; Origin : in world
;;; XAxis : translated from world points
;;; YAxis : translated from world points
;;; Activate : Set as ActiveUCS
;;;
;;;Returns : or nil.
;;----------------------------------------------------------------------------
(defun UscGetOrSet (NewUcsName Origin XAxis YAxis Activate / ActD objUCS ActD UCSs)
(setq ActD (jlgg-ActDoc))
(setq UCSs (vla-get-UserCoordinateSystems ActD))
(or NewUcsName (setq NewUcsName "_UCSTemp"))
(or Origin (setq Origin (getvar "ucsorg"))) ; 3D WCS coordinates
(or XAxis (setq XAxis (getvar "ucsxdir"))) ; 3D WCS coordinates specifying a point on the positive X axis of the UCS
(or YAxis (setq YAxis (getvar "ucsydir"))) ; 3D WCS coordinates specifying a point on the positive Y axis of the UCS.
;;
(setq objUCS (vla-add UCSs
(vlax-3d-point '(0.0 0.0 0.0)) ;origin
(vlax-3d-point XAxis) ;x-axis
(vlax-3d-point YAxis) ;y-axis
NewUcsName
)
)
(vla-put-origin objUCS (vlax-3d-point Origin))
(if Activate
(vla-put-activeucs ActD objUCS)
)
objUCS
)
;;
;;------------------------------UcsChgOrg -----------------------------
;;; PtOrg : punto en coordenadas Universales (WCS)
;;; Ejemplo: (setq a (UcsChgOrg (trans (getpoint) 1 0)))
;;---------------------------------------------------------------------
(defun UcsChgOrg (PtOrg / NameUcs AngVecX UcsTmp VectX VectY)
(if (= (setq NameUcs (getvar 'UCSNAME)) "")
(setq NameUcs nil)
)
(setq UcsTmp (UscGetOrSet NameUcs PtOrg nil nil T))
);c.defun
;;------------------------------ Ucs2P -----------------------------------
;;; PtOrg : punto en coordenadas Universales (WCS)
;;; PtDirX : punto de dirección X en coordenadas Universales (WCS)
;;; Activate: Activa el nuevo ucs
;;; Ejemplo :
;;; (defun c:Pru_Ucs2P (/ p1 pX)
;;; (cond
;;; ((not (setq p1 (aux:Getpoint nil nil "\nPunto de Origen: "))))
;;; ((not (setq pX (aux:Getpoint '(32) p1 "\nDirección X: "))))
;;; ;(T (Ucs2P nil (trans p1 1 0) (trans pX 1 0) t))
;;; ;;or
;;; (T (Ucs2P "UCSPepe" (trans p1 1 0) (trans pX 1 0) t))
;;; )
;;; )
;;------------------------------------------------------------------------
(defun Ucs2P (NameUcs PtOrg PtDirX Activate / UcsTmp)
(cond
(NameUcs)
((= (setq NameUcs (getvar 'UCSNAME)) "")
(setq NameUcs nil)
)
)
(setq PtDirY (polar '(0 0 0) (+ (angle PtOrg PtDirX)(/ pi 2.0)) 1.0))
(setq PtDirX (polar '(0 0 0) (angle PtOrg PtDirX) 1.0))
(setq UcsTmp (UscGetOrSet NameUcs PtOrg PtDirX PtDirY Activate))
);c.defun
;;____________________________________________
;convert angle from UCS to WCS
(defun WcsAng (ang)
(angle
(trans '(0 0 0) 1 0)
(trans (polar '(0 0 0) ang 1.0) 1 0)
)
)
(defun Ang2Wcs (ang) (WcsAng ang))
;;____________________________________________
;convert angle from WCS to UCS
(defun UcsAng (ang)
(angle
(trans '(0 0 0) 0 1)
(trans (polar '(0 0 0) ang 1.0) 0 1)
)
)
(defun Ang2Ucs (ang)(UcsAng ang))
;;--------------------------------------------------------------------
;;Convierte angulos de un sistema de coordenadas a otro
;;--------------------------------------------------------------------
(defun CvtEntCode210 (Arg)
(cond ((= (type Arg) 'LIST) Arg)
((= (type Arg) 'ENAME) Arg)
((= (Type Arg) 'VLA-OBJECT) (vlax-vla-object->ename Arg))
(T nil)
);c.cond
);c.defun
;convert angle from OBJ to WCS
;(Cod210 = ENAME, VLA-OBJECT or List de codigo 210 de entidad (x y z))
(defun AngObj2Wcs (ang Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210))
(angle
(trans '(0 0 0) Cod210 0)
(trans (polar '(0 0 0) ang 1.0) Cod210 0)
)
);c.if
);c.defun
;convert angle from WCS to OBJ
;(Cod210 = ENAME, VLA-OBJECT or List de codigo 210 de entidad (x y z))
(defun AngWcs2Obj (ang Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210))
(angle
(trans '(0 0 0) 0 Cod210)
(trans (polar '(0 0 0) ang 1.0) 0 Cod210)
)
);c.if
);c.defun
;convert angle from OBJ to UCS
;(Cod210 = ENAME, VLA-OBJECT or List de codigo 210 de entidad (x y z))
(defun AngObj2Ucs (ang Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210))
(angle
(trans '(0 0 0) Cod210 1)
(trans (polar '(0 0 0) ang 1.0) Cod210 1)
)
);c.if
);c.defun
;convert angle from UCS to OBJ
;(Cod210 = ENAME, VLA-OBJECT or List de codigo 210 de entidad (x y z))
(defun AngUcs2Obj (ang Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210))
(angle
(trans '(0 0 0) 1 Cod210)
(trans (polar '(0 0 0) ang 1.0) 1 Cod210)
)
);c.if
);c.defun
;; ------------------ Coordenadas y Puntos -----------------------------------------------------
;;Traslacion de coordenadas del objeto a traves del codigo de vector normal o de extrusion (210)
;;o la entidad. (Cod210 = ENAME, VLA-OBJECT or List de codigo 210 de entidad (x y z))
(defun TransPtEntToUCS (pt Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210)) (trans pt Cod210 1))
)
(defun TransPtEntToWCS (pt Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210))(trans pt Cod210 0))
)
;------------------------------------------------------
(defun TransPtUCSToEnt (pt Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210)) (trans pt 1 Cod210))
)
(defun TransPtWCSToEnt (pt Cod210)
(if (setq Cod210 (CvtEntCode210 Cod210))(trans pt 0 Cod210))
)
;;--------------------------------------------------------------------
;;Traslada una lista de puntos al sistema de coordenadas de usuario
;;--------------------------------------------------------------------
(defun TransLPtsUCS (LisPts) (mapcar ' (lambda (x) (trans x 0 1)) LisPts))
;;--------------------------------------------------------------------
;;Traslada una lista de puntos al sistema de coordenadas UNIVERSAL
;;--------------------------------------------------------------------
(defun TransLPtsWCS (LisPts) (mapcar ' (lambda (x) (trans x 1 0)) LisPts))
;;*************** FIN Utiles UCS *************************************
;;---------------------------------------------------------
;;Punto medio de dos puntos Pt1 y Pt2
;;---------------------------------------------------------
(defun jlgg-MidPt (Pt1 Pt2)
(polar Pt1 (angle Pt1 Pt2)(/ (distance Pt1 Pt2) 2.0))
)
;;--------------------------------------------------
;;Zerop Z de una lista de punto
;;--------------------------------------------------
(defun jlgg-flatten_pt (pt)(list (car pt)(cadr pt) 0.0))
;;--------------------------------------------------
;;Punto 3D a 2D
;;--------------------------------------------------
(defun jlgg-2DPt (pt)(list (car pt)(cadr pt)))
;;------------------------------- jlgg-GetpointEx -------------------------------------;;
;; lstInitget: '(6) o '("Caliete Fria") o '(6 "Caliete Fria") o nil ;;
;; ;;
;;Ejemplos: ;;
;; (jlgg-GetpointEx '(0 0 0) "\nPunto inicial o [Caliete/Fria]: " '(1 "Caliete Fria")) ;;
;; (jlgg-GetpointEx nil nil nil) ;;
;;-------------------------------------------------------------------------------------;;
(defun jlgg-GetpointEx (PtRef Msg lstInitget / lstArg PtTmp)
;;Mensaje
(if (not Msg)(setq Msg "\nPrecise punto: "))
(setq lstArg (cons Msg lstArg))
;;Punto de referencia
(if (and PtRef (listp PtRef))
(setq lstArg (cons PtRef lstArg))
)
;;Initget
(if (and lstInitget (listp lstInitget))
(apply (function initget) lstInitget)
)
(if (not
(and
(setq PtTmp (vl-catch-all-apply (function getpoint) lstArg))
(not (vl-catch-all-error-p PtTmp))
)
)
(setq PtTmp nil)
)
PtTmp
)
;;------------------------------- jlgg-GetDistEx --------------------------------;;
;; lstInitget: '(6) o '("Caliete Fria") o '(6 "Caliete Fria") o nil ;;
;; ;;
;;Ejemplos: ;;
;; (jlgg-GetDistEx '(0 0 0) "\nDistancia o [Caliete/Fria]: " '(6 "Caliete Fria"));;
;; (jlgg-GetDistEx nil nil nil) ;;
;;-------------------------------------------------------------------------------;;
(defun jlgg-GetDistEx (PtRef Msg lstInitget / lstArg DisTmp)
;;Mensaje
(if (not Msg)(setq Msg "\nDistancia: "))
(setq lstArg (cons Msg lstArg))
;;Punto de referencia
(if (and PtRef (listp PtRef))
(setq lstArg (cons PtRef lstArg))
)
;;Initget
(if (and lstInitget (listp lstInitget))
(apply (function initget) lstInitget)
)
(if (not
(and
(setq DisTmp (vl-catch-all-apply (function getdist) lstArg))
(not (vl-catch-all-error-p DisTmp))
)
)
(setq DisTmp nil)
)
DisTmp
)
;;----------------------- aux:Getpoint-------------------------------
;;; Initget : Lista de paremetro de initget : '( 6 "Opciones pUnto")
;;; PtRef: Punto de referencia para (getpoint Ptref "Mens: ")
;;; PrmpMens: Mensage para getpoint.
;;-------------------------------------------------------------------
(defun aux:Getpoint (Initg PtRef PrmpMens / lstArg pt)
(if (not PrmpMens)(setq PrmpMens "\nIndique punto:"))
(if (not initg) (setq initg (list 0)))
(cond
((not PtRef)
(setq lstArg (list PrmpMens))
)
(T
(setq lstArg (list PtRef PrmpMens))
)
)
(apply (function initget) initg)
(if (vl-catch-all-error-p
(setq pt (vl-catch-all-apply (function getpoint) lstArg)))
nil
pt
)
)
;--------------------------- AUX_XAddLWPolyline ------------------------
;;Creación de una polilinea con entmake; lista de puntos, color, Grosor
;;Ejemplo: (jlgg-MakeLwPol pts "prueba" 2 nil nil 2.45 t)
;-----------------------------------------------------------------------
(defun jlgg-MakeLwPol (LisPts Capa Col Gro Ltype Elev LWeight IsClosed / Pol)
(setq Pol
(entmakex
(append
(list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")
(cons 8 (if Capa Capa (getvar "CLAYER"))) ;Capa
;;(cons 62 (if Col Col 256)) ;color
(cons 38 (if Elev Elev 0.0)) ;Elevation
(if Ltype (cons 6 Ltype)
(cons 6 (getvar "CELTYPE"))) ;tipo de linea
(cons 90 (length LisPts)) ;n.vertices
(if (and IsClosed (> (length LisPts) 2)) ;cerrada-abierta
(cons 70 129)
(cons 70 128)
)
(cons 43 (if Gro Gro 0.0)) ;Grosor
;;LWeight -1: "PorCapa"
;;LWeight -2: "PorBloque"
;;LWeight -3: "PorDefecto"
(if LWeight (cons 370 LWeight) (cons 370 -2));LineWeight
);c.list
;;_________________________________
;;color = lista tipo:
;((62 . 23)) o
;((62 . 93) (420 . 6804829)) o
;((62 . 2) (420 . 16770347) (430 . "PANTONE+ Color Bridge Uncoated$PANTONE Process Yellow U"))
(if (not Col)
(list (cons 62 256))
Col
)
;;______________________________________________
;;lista de puntos:
(mapcar (function (lambda (x) (cons 10 x))) LisPts)
);c.append
);c.entmk
);c.setq
Pol
);c.defun
;;------------------------- GetVertexLWPol ---------------------------
;;Obtención de los vertices de una LWPOLYLINE
;;--------------------------------------------------------------------
(defun jlgg-GetVertexLWPol ( oPol / Vertices)
(setq Vertices (vl-remove-if-Not (function (lambda (pair) (= (car pair) 10))) (entget (GetENAM-Obj oPol))))
(mapcar (function cdr) Vertices)
)
;;---------------------- PtPerpToVec ---------------------------------------
;; Punto perpendicular a un vector desde PtChk
;;--------------------------------------------------------------------------
(defun jlgg-PtPerpToVec ( p1 p2 ptCheck / tr )
(setq tr (mapcar '- p2 p1)
p1 (trans p1 0 tr)
ptCheck (trans ptCheck 0 tr)
)
(trans (list (car p1) (cadr p1) (caddr ptCheck)) tr 0)
)
;;--------------------------- jlgg-OffsetEnt -----------------------------------
;; Offset de una entidad.
;;------------------------------------------------------------------------------
(defun jlgg-OffsetEnt (objBase offset_d / ObjOff1 ListObjsOffset Retval)
(setq objBase (jlgg-getvla-obj objBase))
(if (null (vl-catch-all-error-p
(setq ObjOff1 (vl-catch-all-apply (function vla-offset) (list objBase offset_d)))))
(if (setq ListObjsOffset
(append (vlax-safearray->list (vlax-variant-value ObjOff1))
ListObjsOffset))
(setq Retval (car ListObjsOffset))
);c.if
);c.if
Retval
)
;;------------------------ jlgg-Delete-Object ------------------------------
;; borrar un objeto...
;;--------------------------------------------------------------------------
(defun jlgg-Delete-Object (obj / del)
(if (vl-catch-all-error-p
(setq Del (vl-catch-all-apply
(function vla-delete)
(list (jlgg-GetVLA-Obj obj)))))
nil
t)
)
;;; ___ __ ___ __ __ ;;;
;;; | |_ \_/ | / \(_ ;;;
;;; | |__/ \ | \__/__) ;;;
;;; ;;;
;;------------------------- jlgg-SetStyTxt ---------------------------------------
;; José Luis García G. 23 Julio, 04
;;Crea (si no existe) un estilo de texto
;;y o modifica las las propiedades (Font, Height, Width) si se indican
;; Ejemplos:
;; (jlgg-SetStyTxt "pepe34" nil nil nil nil)
;; (jlgg-SetStyTxt "pepe344" "ARIAL.TTF" 0.15 1 nil)
;; (jlgg-SetStyTxt "MiStilo02" "stylu.ttf" 0.0 1.0 nil)
;; (jlgg-SetStyTxt "pepe34" "styl.ttf" 0.0 1.0 t) = Error con aviso
;;Nota: siempre devueve el estilo de texto (se haya modificado o no)
;;--------------------------------------------------------------------------------
(defun jlgg-SetStyTxt (TxTStyle Font Height Width MsgError / col_Sty_txt Txt_Sty Font$)
(if (setq Txt_Sty (vla-add (vla-get-TextStyles (jlgg-ActDoc)) TxTStyle))
(progn
(if Font ;;Fuente
(cond
((setq Font$ (findfile Font))
(vl-catch-all-apply 'vla-put-FontFile (list Txt_Sty Font$)))
((setq Font$ (findfile (strcat (getenv "Windir") "\\fonts\\" Font)))
(vl-catch-all-apply 'vla-put-FontFile (list Txt_Sty Font$)))
(T (if MsgError (alert (strcat "Tipo de Fuente: \n\n \"" Font "\"\n\nNo encontrada o No Valida....."))))
);c.cond
);c.if
(vl-catch-all-apply 'vla-put-Height (list Txt_Sty Height))
(vl-catch-all-apply 'vla-put-Width (list Txt_Sty Width))
(vl-catch-all-apply 'vla-put-ObliqueAngle (list Txt_Sty 0.0))
(vl-catch-all-apply 'vla-put-TextGenerationFlag (list Txt_Sty 0))
(vl-catch-all-apply 'vla-put-Backward (list Txt_Sty :vlax-false))
(vl-catch-all-apply 'vla-put-UpsideDown (list Txt_Sty :vlax-false))
);c.prg
);c.if
(vlax-vla-object->ename Txt_Sty)
);c.defun
;;------------------------ cad_div --------------------------------------
;;ESTA RUTINA RECOGE una CADENA DE texto y un simbolo de separacion
;;ejemp.- cadena="*jose*luis*" simbolo="*" y lo combierte en una lista
;;con cadenas separadas ("jose" "luis")
;;-----------------------------------------------------------------------
(defun cad_div (str pat / i j n lst chr1)
(if str
(cond
((/= (type str)(type pat) 'STR))
((= (strlen str) 0)'(""))
((= (strlen pat) 0) (list str))
((= str pat)'(""))
(T
(setq i 0 n (strlen pat))
(while (setq j (vl-string-search pat str i))
(setq chr1 (substr str (1+ i)(- j i)))
(if (> (strlen chr1) 0)(setq lst (cons chr1 lst)) )
(setq i (+ j n))
)
(setq chr1 (substr str (1+ i)))
(if (> (strlen chr1) 0)
(setq lst (cons chr1 lst))
)
(if lst (reverse lst) '(""))
)
)
)
)
;;Otro modo;
;;_______________________________________________________
(defun str2lst (str pat / pos )
(if (setq pos (vl-string-search pat str))
(vl-remove "" (cons (substr str 1 pos)
(str2lst (substr str (+ pos 1 (strlen pat))) pat)
))
(list str)
)
)
;;------------------------ Cad_Join ------------------------------------------
;; Esta rutina recoge una lista de cadena de texto y un simbolo de separacion
;; y lo une en una sola cadena separada por el separador indicado
;; ejemplo.- (Cad_Join '("VA*" "VC*" "BA*" "BC*") "|")
;; Resultado: "VA*|VC*|BA*|BC*"
;;----------------------------------------------------------------------------
(defun Cad_Join (LisStr Sep / ValTmp)
(setq ValTmp "")
(mapcar (function (lambda (Str)
(setq ValTmp (strcat ValTmp Str Sep))
)) LisStr)
(setq ValTmp (vl-string-right-trim Sep ValTmp))
)
;;;--------------------- Str2Lst_WithBlank --------------------------------------------------
;;; Divide una cadena en cadenas mas pequeñas de longitud maxima
;;; indicada en "MaxLenLine" y siempre haciendo la división en
;;; un espacio en blanco.
;;; ejemplo:
;;; (setq s (strcat "Lorem ipsum dolor sit amet, consectetur adipiscing elit. "
;;; "Morbi sed dictum quam. Morbi nisi augue, aliquam a ultricies sit amet, "
;;; "eleifend in metus. Donec odio tellus, egestas a risus maximus, "
;;; "tempor egestas eros."))
;;; (princ s)
;;; (Str2Lst_WithBlank s 50)
;;;Result:
;;; ("Lorem ipsum dolor sit amet, consectetur adipiscing "
;;; "elit. Morbi sed dictum quam. Morbi nisi augue, aliquam "
;;; "a ultricies sit amet, eleifend in metus. Donec odio "
;;; "tellus, egestas a risus maximus, tempor egestas eros."
;;; )
;;-------------------------------------------------------------------------------------------
(defun Str2Lst_WithBlank (s MaxLenLine / go i s1 s2 slen)
(setq slen (strlen s))
(while (> slen MaxLenLine)
;;search " "
(setq i 0 go T)
(while (and go i (< i MaxLenLine))
(if (setq i (VL-STRING-SEARCH " " s i))
(setq i (1+ i))
)
(if (not (and (setq i2 (VL-STRING-SEARCH " " s (1+ i)))
(< i2 MaxLenLine)))
(setq go nil)
)
)
(cond
(i
(setq s1 (substr s 1 i))
(setq s (substr s (1+ i)))
(setq s2 (cons s1 s2))
(setq slen (strlen s))
)
(T (setq slen (1- MaxLenLine))) ;;salir del bucle:
)
)
(if (/= s "")
(setq s2 (cons s s2))
)
(reverse s2)
)
;;;-------------------- jlgg-rtos -------------------------------------
;;; Rtos personalizado estable
;;;--------------------------------------------------------------------
(defun jlgg-rtos ( real units prec / dimzin result )
(if (not prec)(setq prec (getvar "luprec")))
(if (not units)(setq units (getvar "lunits")))
(setq dimzin (getvar "dimzin"))
(setvar "dimzin" 0)
(setq result (vl-catch-all-apply (function rtos) (list real units prec)))
(setvar "dimzin" dimzin)
(if (not (vl-catch-all-error-p result))
result
)
)
;;---------------------------------- jlgg-MakeMtext ----------------------------------------------;;
;;Ejemplo: ;;
;; (jlgg-MakeMtext (trans (getpoint) 1 0) 2.5 "juan" (* pi 0.5) readable ;;
;; "_MC" "MiCapa" MiEstilo MyCol LWeight T_Mask t)) ;;
;;------------------------------------------------------------------------------------------------;;
(defun jlgg-MakeMtext (PtTxt ;;punto de inserción ;;
Htxt ;;altura de texto ;;
StrTxt ;;Cadena ;;
angTxt ;;angulo de rotación ;;
readableforce ;;forzar texto leible;;
JustTxt ;;justificación ;;
layTxt ;;capa ;;
StyTxt ;;estylo texto ;;
ColTxt ;;color ;;
LWeight ;;Grosor de Línea ;;
Mask ;;Mascara ;;
Visible ;;Visibilidad ;;
/
LJust Just$ LTmp xdlist
;|Funciones|; GetAngForceReadable
)
;;____________________________________________________
(defun GetAngForceReadable (Ang)
(if (and (> Ang (/ pi 2))
(<= Ang (* 3 (/ pi 2))))
(setq Ang (+ Ang pi))
) ;c.if
Ang
)
;;----------------------------------- MAIN ------------------------------------------
;;Justificación;
(setq LJust '(("Left" "_L" 7) ("Center" "_C" 8) ("Middle" "_M" 5) ("Right" "_R" 9)
("Top Left" "_TL" 1) ("Top Center" "_TC" 2) ("Top Right" "_TR" 3)
("Middle Left" "_ML" 4)("Middle Center" "_MC" 5) ("Middle Right" "_MR" 6)
("Bottom Left" "_BL" 7) ("Bottom Center" "_BC" 8) ("Bottom Right" "_BR" 9)))
(if (setq Just$ (vl-some (function (lambda (x) (member JustTxt x))) LJust))
(setq Just$ (last Just$))
)
;;Angulo del texto:
(if (not (and angTxt (numberp angTxt)))
(setq angTxt 0.0)
)
(if readableforce
(setq angTxt (GetAngForceReadable angTxt))
)
;;Estilo:
(if (not
(and StyTxt
(= (type StyTxt) 'STR)
(tblsearch "style" StyTxt)))
(setq StyTxt (getvar 'TEXTSTYLE))
)
;;Entmake
(setq LTmp
(list '(0 . "MTEXT")'(100 . "AcDbEntity")'(100 . "AcDbMText")
(if layTxt (cons 8 layTxt)(cons 8 (getvar "CLAYER"))) ;;capa ;;
(if ColTxt (cons 62 ColTxt) (cons 62 256)) ;;color ;;
(cons 10 PtTxt) ;;punto de inserción ;;
(if Htxt (cons 40 Htxt)(cons 40 (getvar "TEXTSIZE"))) ;;altura de texto ;;
'(41 . 0.0) ;;Anchura rectangulo ;;
(cons 50 angTxt) ;;angulo de rotación ;;
(if Just$ (cons 71 Just$) (cons 71 7)) ;;justificación ;;
'(72 . 5) ;;Direccion ;;
(cons 1 StrTxt) ;;Cadena ;;
(if LWeight (cons 370 LWeight) (cons 370 -2)) ;;Grosor de Línea ;;
(cons 7 StyTxt) ;;estylo texto ;;
(if Visible (cons 60 0) (cons 60 1)) ;;Visibilidad ;;
)
)
(if MasK
(setq LTmp (append LTmp '((90 . 3) (63 . 256) (45 . 1.0) (441 . 2146608)))) ;;Mascara ;;
)
(setq Mtext (entmakex LTmp))
);c.defun
;;; __ __ __ __ __ ;;;
;;; |__)| / \/ \/ \|_ (_ ;;;
;;; |__)|__\__/\_\/\__/|____) ;;;
;;; ;;;
;;---------------------------------- GetDynamicProps -------------------------------------;;
;;Obtiene la lista de propiedades de un bloque dinámico ;;
;; Devuelve: ;;
;; (("Distancia1" . 1.77415) ("Ángulo1" . 0.0) ("Origin" 0.0 0.0) ;;
;; ("Distancia2" . 0.5) ("Origin" 0.774154 1.0) ("Visibilidad1" . "Fondo No")) ;;
;;----------------------------------------------------------------------------------------;;
(defun GetDynamicProps (oBlk)
(mapcar
(function
(lambda (DynBlockRefProp)
(cons
(vla-get-propertyname DynBlockRefProp)
(vlax-get DynBlockRefProp 'value)
)
)
)
;;(# ..)
(vlax-invoke oBlk (function getdynamicblockproperties))
)
)
;;---------------------------------- GetDynamicProps -------------------------------------;;
;;Obtiene el valor de una propiedad de un bloque dinámico ;;
;; Ejemplo: ;;
;; (GetDynamicPropValue oBlk "Visibilidad1") ;;
;;----------------------------------------------------------------------------------------;;
(defun GetDynamicPropValue (oBlk sProp)
(vl-some
(function
(lambda (DynBlockRefProp)
(if (= (strcase sProp) (strcase (vla-get-propertyname DynBlockRefProp)))
(vlax-get DynBlockRefProp 'value)
)
)
)
;;(# ..)
(vlax-invoke oBlk (function getdynamicblockproperties))
)
)
;;---------------------------------- SetDynamicPropValue ---------------------------------;;
;;Modifica el valor de una propiedad de un bloque dinámico ;;
;; Ejemplos: ;;
;; (SetDynamicPropValue oBlk "Visibilidad1" "Fondo Si") ;;
;; (SetDynamicPropValue oBlk "Distancia1" 10.56) ;;
;;----------------------------------------------------------------------------------------;;
(defun SetDynamicPropValue (oBlk sProp NewVal / Return MensErr)
;;(vla-get-UnitsType DynBlockRefProp) ;;sin implementar
;;acDynamicBlockReferencePropertyUnitsType
;;;acNoUnits : 0
;;;acAngular : 1
;;;acDistance : 2
;;;acArea : 3
(setq Return
(vl-some
(function
(lambda (DynBlockRefProp / RetVal)
(if (= (strcase sProp) (strcase (vla-get-propertyname DynBlockRefProp)))
(cond
((= (vla-get-ReadOnly DynBlockRefProp) :vlax-true)
(setq MensErr (strcat "La propiedad [" sProp "] es de solo lectura")
RetVal nil)
)
((vl-catch-all-error-p
(setq ValVariant (vl-catch-all-apply
(function vlax-make-variant)
(list NewVal (vlax-variant-type (vla-get-value DynBlockRefProp))))))
(setq MensErr (strcat "La propiedad [" sProp "] no admite el tipo de dato: " (vl-princ-to-string (type NewVal)))
RetVal nil)
)
((vl-catch-all-error-p
(vl-catch-all-apply
(function vla-put-value)
(list DynBlockRefProp ValVariant)
)
)
(setq MensErr (strcat "No se pudo asignar el valor: "
(vl-princ-to-string NewVal) " a la propiedad [" sProp "]")
RetVal nil)
)
(T (setq Retval NewVal))
);c.cond
);c.if
(if RetVal RetVal nil)
)
)
;;(# ..)
(vlax-invoke oBlk (function getdynamicblockproperties))
);vl-some
);c.setq
(if MensErr (print MensErr))
Return
)
;;*************** FIN Utiles cadenas *************************************
(princ "\nLa Marmita: Auxiliares Cargados...")
(princ)
Hasta la próxima publicación..
Excelente material para estudiar.
ResponderEliminarAun sigo aprendiendo de tu material muchisimas gracias
ResponderEliminarMe alegro Octavio, lastima que no tenga tiempo para actualizarlo para el blog.
Eliminar