Perpendiculares a un eje
+2
bernie67
eliasp
6 participantes
Página 1 de 2.
Página 1 de 2. • 1, 2
Perpendiculares a un eje
Que tal señores, buen día para todos.
Tengo un problema que se resolvió en Hispacad... ya todos conocen la historia. El hecho es que no encuentro la solución y como no hay donde "re-encontrala" tengo que volver a preguntar. Es un tema recurrente y que lamentablemente, no tomé nota en forma adecuada. Se trata de colocar una línea perpendicular a un eje, intenté "re-hacerla" pero no me salió, si alguien puede ayudarme con eso, se los agradeceré....
https://dl.dropboxusercontent.com/u/58052688/macro1.dwg
Saludos y gracias
Tengo un problema que se resolvió en Hispacad... ya todos conocen la historia. El hecho es que no encuentro la solución y como no hay donde "re-encontrala" tengo que volver a preguntar. Es un tema recurrente y que lamentablemente, no tomé nota en forma adecuada. Se trata de colocar una línea perpendicular a un eje, intenté "re-hacerla" pero no me salió, si alguien puede ayudarme con eso, se los agradeceré....
- Código:
(defun c:cadenas()
(setq marca "marka") <<---- Esto no se porqué, pero solo así funcionó, jajajajaja
(setq cadena 10)
(if(null (tblobjname "BLOCK" marca))
(progn
(setvar "plinewid" 0.05)
(command "_pline" (list 0 0) (list 0 1)"")
(setq xb (entlast))
(command "_block" marca (list 0 0.5) xb "")
(setvar "plinewid" 0)
))
(vl-cmdf "undo""begin")
(while (not (setq eje (car(entsel "\nSelecciona Eje: ")))))
(setq ob(vlax-ename->vla-object eje))
(setq ini(vlax-curve-getstartpoint ob)
fin(vlax-curve-getendpoint ob)
long(vlax-curve-getdistatpoint ob fin)
par(vlax-curve-getParamAtPoint ob fin)
dista 0
punto 0
)
(while(>= long dista)
(setq punto(vlax-curve-getpointatdist ob dista))
(setq slp (vlax-curve-getfirstDeriv ob par))
(setq ang-rad (atan (/ (cadr slp) (car slp))))
(setq ang-grad(/ (* 180 ang-rad )pi ))
(command "_-insert" marca punto 1 1 ang-grad)
(setq texto(mas-en-texto (rtos dista 2 2)))
(command "_text" "_C" punto 1.5 (+ 90 ang-grad) texto)
(setq dista(+ cadena dista))
)
(setq punto(polar punto(* 0.5 pi)10))
(command "_text" "_C" punto 2.5 ang-rad (rtos long 2 2))
(vl-cmdf "undo""end")
)
https://dl.dropboxusercontent.com/u/58052688/macro1.dwg
Saludos y gracias
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Hola Eliasp
Me encontré esta rutina entre las que guardo, del maestro Jose L. García, del foro de Hispacad. No se si te sirva
;;; _ _ _ _
;;; | || |(_) ___ _ __ __ _ __ __ _ __| |
;;; | __ || |(_-<| '_ \/ _` |/ _|/ _` |/ _` |
;;; |_||_||_|/__/| .__/\__,_|\__|\__,_|\__,_|
;;; |_|
;;; www.Hispacad.com
;;; CopyBlkAlong.LSP V.3.18 - 3/10/13
;;; CopyBlkAlong.LSP V.3.09 - 3/7/10
;;07/10/2013:
;;Mensajes en ingles y castellano para blogs y foros
;;Posts in English and Castilian for blogs and forums
; Cargar las funciones ActiveX (Visual Lisp)
(vl-load-com)
;;============================ C:CopyBlkAlong ===============================================
;; Copia de bloque a lo largo de una curva
;; Copy block along a curve
;; Jose L. García G. = Hispacad.com
;;===========================================================================================
(defun C:CopyBlkAlong (/ ObjCurve ObjBlk prev LongCurve $Blcopy$ $IncreDis$ ModVars
;|funcions local|; *error* RoundToNearest MoveInteractive grxPt)
;;------------------------------ grxPt -----------------------------------------
;; dibuja y resalta en pantalla un punto con una X
;; draw and highlight on-screen with an X point
;;------------------------------------------------------------------------------
(defun grxPt (p col)
(setq h (/ (getvar "viewsize") 70))
(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
;;------------------------------ *error* ---------------------------------------
;; MAIN ERROR LOCAL
;;------------------------------------------------------------------------------
(defun *error* (msg)
(cond
((not msg)) ; Normal exit
;;Mens in English and Castilian
((member msg '("console break" "Function cancelled" ; <esc> or (quit)
"Función cancelada" "Interrupción desde el teclado" "Interrupción de salida")))
((princ (strcat "\nError CopyBlkAlong: " msg))) ; Fatal error, display it
)
;;Borrar el bloque temporal si se produjo error
;; Delete temporary block if error occurred
(if (and $Blcopy$
(not (vlax-erased-p $Blcopy$)))
(progn
(vl-catch-all-apply (function vla-delete) (list $Blcopy$))
(setq $Blcopy$ nil)
)
);c.if
;;Restart variables
(mapcar (function (lambda (pair)
(setvar (car pair) (eval (car pair)))
(set (car pair) nil)
)) ModVars)
(redraw)
(princ)
);c.defun
;;--------------------------- RoundToNearest -----------------------------------
;; Redondear Numero a Numero mas cercano
;; Round number to the nearest number
;;-------------------------------------------------------------------------------
(defun RoundToNearest (dblVal dblNear / dblTemp Retval)
(if (not (zerop dblNear))
(progn
(setq dblNear (* dblNear 100))
(setq dblTemp (fix (/ (+ (* dblVal (expt 10 2)) (/ dblNear 2)) dblNear)))
(setq RetVal (/ (* dblTemp dblNear) (expt 10 2)))
)
(setq Retval 0)
)
RetVal
);c.defun
;;--------------------------- MoveInteractive -------------------------------------
;; Funcion Principal, Mueve/Copia interactivamente un bloque alolargo de una curva
;; Primary Function, Move / Copy a block interactively alolargo a curve
;;----------------------------------------------------------------------------------
(defun MoveInteractive ( / $blcopy$ ang$ deriv1 dis inp loop
NameBlq param pt pt1 pt2 g1 sx sy tmp$
ChildIncreAng Ang90 angBlk a1
;|Sub|; go:msg Calculos)
;;__________________________________________________________________________________________
(defun Go:Guia ()
(grdraw (trans pCv 0 1)
(trans pt 0 1)
-1
)
(grxPt (trans (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint $Blcopy$))) 0 1) -1)
)
(defun go:msg ()
(princ (strcat "\r[G]uia:" (if $Guia$ "Si" "No")
", [I]ntervalo:" (rtos $Intervalo$ 2)
", [D]istancia:" (rtos Dis 2)
", [+/-][O]ffset:"(rtos $crv-off$ 2)
", [</>][A]ngulo:"(angtos $IncreAng$ 0)
", Click inserta [Exit]:"))
;;(princ (strcat "\r[G]uide:" (if $Guia$ "Si" "No")
;; ", [I]nterval:" (rtos $Intervalo$ 2)
;; ", [D]istance:" (rtos Dis 2)
;; ", [+/-][O]ffset:"(rtos $crv-off$ 2)
;; ", [</>][A]ngle:"(angtos $IncreAng$ 0)
;; ", Click insert [Exit]:"))
)
(defun Calculos (ForceDis)
(setq param (vlax-curve-getParamAtPoint ObjCurve pCv)
deriv1 (vlax-curve-getFirstDeriv ObjCurve param) ;direction vector
pt2 (mapcar '+ pCv deriv1)
angBlk (+ $IncreAng$ (angle pt2 pCv))
)
(setq a1 (cond (ForceDis
(- (angle pCv pt2)(/ pi 2))
)
((angle pCv pt))))
(setq pt1 (vlax-3D-point (polar pCv a1 $crv-off$)))
);c.defun
;;------------------------------ MAIN -----------------------------------------------------
(setq ChildIncreAng (/ pi (/ 180 15.0)) ;;15 grados
Ang90 (/ pi 2.0)) ;;90 grados
(setq xa (angle '(0.0 0.0 0.0)
(trans (getvar 'UCSXDIR) 0 (trans '(0.0 0.0 1.0) 1 0 t))))
;;Datos del Bloque
(setq NameBlq (cdr (assoc 2 (entget ObjBlk)))
Sx (cdr (assoc 41 (entget ObjBlk)))
Sy (cdr (assoc 42 (entget ObjBlk))))
(setq $Blcopy$ (vla-Copy (vlax-ename->vla-object ObjBlk)))
(setq loop T)
;;(print)
(while loop
(setq inp (grread t 15 0)) ; get input, tracking
(setq g1 (car inp) pt (cadr inp)) ; isolate g1 and # or point
(cond
((= (type pt) 'LIST)
(setq pCv (vlax-curve-getClosestPointTo ObjCurve (setq pt (trans pt 1 0))) ;punto en curva
dis (vlax-curve-getDistAtPoint ObjCurve pCv))
(if (not (zerop $Intervalo$))
(progn
(if (> (setq Tmp$ (RoundToNearest dis $Intervalo$)) LongCurve)
(setq dis LongCurve)
(setq dis Tmp$)
)
(cond
((setq pCv (vlax-curve-getPointAtDist ObjCurve Dis)))
((> Dis LongCurve) (setq pCv (vlax-curve-getEndPoint ObjCurve)))
((equal Dis LongCurve 1.0e-004) (setq pCv (vlax-curve-getEndPoint ObjCurve)))
(t (setq pCv (vlax-curve-getStartPoint ObjCurve)))
)
(Calculos t)
);c.prg
(Calculos nil)
);c.if
)
);c.cond
(cond
((= g1 3) ;; "pick" button?
(vla-Copy $Blcopy$)
;(setq loop nil)
)
((= g1 5) ;; tracking point
(go:msg)
;;(COMMAND "_.change" $Blcopy$ pt1 angBlk) ;;NO
(vla-Move $Blcopy$ (vla-get-InsertionPoint $Blcopy$) pt1)
(vla-put-Rotation $Blcopy$ angBlk)
(if $Guia$ (Go:Guia))
(if (and $Guia$ (/= oldG1 5))
(redraw)
)
;;(PRINT $Blcopy$)(PRINC)
)
((and (= g1 2) ;;keyboard
(member pt '(103 71))) ;;key g/G
(setq $Guia$ (not $Guia$))
(redraw)
)
((and (= g1 2)
(member pt '(45 95))) ;; offset -
(setq $crv-off$ (- $crv-off$ $IncreDis$))
)
((and (= g1 2)
(member pt '(43 61))) ;; offset +
(setq $crv-off$ (+ $crv-off$ $IncreDis$))
)
((and (= g1 2)
(member pt '(79 111))) ;; O/o offset
(setq $crv-off$ (cond
((getdist (strcat "\nSpecifique Offset <"
;;"\nSpecify Offset <"
(rtos $crv-off$ 2) ">: ")))
($crv-off$)))
)
((and (= g1 2)
(member pt '(44 60)))
(setq $IncreAng$ (+ $IncreAng$ ChildIncreAng)) ;;>
)
((and (= g1 2)
(member pt '(46 62)))
(setq $IncreAng$ (+ $IncreAng$ (- ChildIncreAng))) ;;<
)
((and (= g1 2) ;;keyboard
(member pt '(65 97))) ;;key a/A
(setq $IncreAng$ (cond
((getangle (strcat "\nAngulo del Bloque;< "
;;"\nAngle Block;< "
(angtos $IncreAng$ 0) " >: ")))
($IncreAng$)))
)
((and (= g1 2) ;keyboard
(member pt '(68 100))) ;Key D/d
(initget "Inicio Fin")
;;(initget "Home End")
(if (setq Tmp$ (getdist (strcat "\nInsertar a distancia o [Inicio/Fin];< "
;;"\nInsert a distance or [Home/End];< "
(rtos Dis 2) " >: ")))
(cond
((= Tmp$ "Inicio" ;|"Home"|;) (setq Dis 0.0))
((= Tmp$ "Fin" ;|"End"|; ) (setq Dis LongCurve))
(T (setq Dis Tmp$))
);c.cond
);c.if
(cond
((setq pCv (vlax-curve-getPointAtDist ObjCurve Dis)))
((> Dis LongCurve)
(prompt (strcat "\nLongitud maxima de curva: ["
;;"\nMaximum length of curve: ["
(rtos LongCurve 2) "].\n"))
(setq pCv (vlax-curve-getEndPoint ObjCurve))
)
((equal Dis LongCurve 1.0e-004)
(prompt (strcat "\nLongitud maxima de curva: ["
;;"\nMaximum length of curve: ["
(rtos LongCurve 2) "].\n"))
(setq pCv (vlax-curve-getEndPoint ObjCurve))
)
(t (setq pCv (vlax-curve-getStartPoint ObjCurve)))
)
(Calculos t)
(vla-Move $Blcopy$ (vla-get-InsertionPoint $Blcopy$) pt1)
(vla-put-Rotation $Blcopy$ angBlk)
(vla-Copy $Blcopy$)
)
((and (= g1 2) ;keyboard
(or (= pt 73)(= pt 105))) ;Key I o i
(initget 4)
(if (setq Tmp$ (getdist (strcat "\nIntervalo entre bloques;< "
;;"\nInterval between blocks;< "
(rtos $Intervalo$ 2) " >: ")))
(if (< Tmp$ LongCurve)
(setq $Intervalo$ Tmp$)
(prompt (strcat "\nIntervalo No Valido, es mayor que la longitud total de curva: ["
;;"\nInvalid range, is greater than the total length of curve:: ["
(rtos LongCurve 2) "].\n"))
);c.if
);c.if
)
((= g1 25) (setq loop nil)) ; button right
(;;(or (and (= g1 6) (= pt 0)) ; button 1, or
(and (= g1 2) ; keyboard and
(or (= pt 13) (= pt 32))) ; CR or blank?
;;);c.or
;(Print "Teclado o cTRL o Espaciadora ")
(setq loop nil) ; exit
)
;(T (setq loop nil)) ; any other grread value ; exit
);c.cond
(setq oldG1 g1)
);c.while
(if (and $Blcopy$
(not (vlax-erased-p $Blcopy$)))
(vla-delete $Blcopy$)
);c.if
);c.defun
;;------------------------------------------------- MAIN -------------------------------------------------------
(setq ModVars
(list '(cmdecho . 0)
'(dimzin . 1)
'(attdia . 0)
'(attreq . 0)
'(snapmode . 0)
'(pickstyle . 0)
(cons 'osmode (boole 7 (getvar 'osmode) 16384))))
(mapcar
(function (lambda (pair)
(set (car pair) (getvar (car pair)))
(setvar (car pair) (cdr pair))
))
ModVars
)
(setq $IncreDis$ 0.1)
;; Variables de documento abiertas
;; Open document Variables
(or $IncreAng$ (setq $IncreAng$ 0))
(or $Intervalo$ (setq $Intervalo$ 0))
(or $crv-off$ (setq $crv-off$ 0.0))
(cond
((not (setq ObjCurve (vl-catch-all-apply (function entsel)(list "Seleccione Curva: " ;|"Select Curve: "|;)))))
((vl-catch-all-error-p ObjCurve))
((not (and (setq ObjCurve (car ObjCurve))
(wcmatch (cdr (assoc 0 (entget ObjCurve))) "SPLINE,ELLIPSE,LINE,ARC,CIRCLE,*POLYLINE")))
(prompt "\nNo ha seleccionado una curva valida.> Spline,Elipse,Linea,Arco,Circulo,Polylinea")
;(prompt "\nYou have not selected a valid curve.> Spline, Ellipse, Line, Arc, Circle or polyline")
)
(T
(cond
((not (setq ObjBlk (vl-catch-all-apply (function entsel)(list "Seleccione Bloque a Insertar: " ;|"Select Block to Insert: "|;)))))
((vl-catch-all-error-p ObjBlk))
((not (and (setq ObjBlk (car ObjBlk))
(wcmatch (cdr (assoc 0 (entget ObjBlk))) "INSERT")))
(prompt "\nNo ha seleccionado un Bloque.")
;;(prompt "\nYou have not selected a Block.")
)
(T
;;Longitud de la curva
(setq LongCurve (vlax-curve-getDistAtParam ObjCurve (vlax-curve-getEndParam ObjCurve))
LongCurve (distof (rtos LongCurve 2 4)))
(if (> $Intervalo$ LongCurve)(setq $Intervalo$ 0.0))
(command "_.UNDO" "_BE")
(grxPt (trans (vlax-curve-getStartPoint ObjCurve) 0 1) 50)
(MoveInteractive)
(redraw)
(command "_.UNDO" "_E")
)
);cond
)
);cond
(*error* nil)
(princ)
);c.defun
(princ)
Me encontré esta rutina entre las que guardo, del maestro Jose L. García, del foro de Hispacad. No se si te sirva
;;; _ _ _ _
;;; | || |(_) ___ _ __ __ _ __ __ _ __| |
;;; | __ || |(_-<| '_ \/ _` |/ _|/ _` |/ _` |
;;; |_||_||_|/__/| .__/\__,_|\__|\__,_|\__,_|
;;; |_|
;;; www.Hispacad.com
;;; CopyBlkAlong.LSP V.3.18 - 3/10/13
;;; CopyBlkAlong.LSP V.3.09 - 3/7/10
;;07/10/2013:
;;Mensajes en ingles y castellano para blogs y foros
;;Posts in English and Castilian for blogs and forums
; Cargar las funciones ActiveX (Visual Lisp)
(vl-load-com)
;;============================ C:CopyBlkAlong ===============================================
;; Copia de bloque a lo largo de una curva
;; Copy block along a curve
;; Jose L. García G. = Hispacad.com
;;===========================================================================================
(defun C:CopyBlkAlong (/ ObjCurve ObjBlk prev LongCurve $Blcopy$ $IncreDis$ ModVars
;|funcions local|; *error* RoundToNearest MoveInteractive grxPt)
;;------------------------------ grxPt -----------------------------------------
;; dibuja y resalta en pantalla un punto con una X
;; draw and highlight on-screen with an X point
;;------------------------------------------------------------------------------
(defun grxPt (p col)
(setq h (/ (getvar "viewsize") 70))
(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
;;------------------------------ *error* ---------------------------------------
;; MAIN ERROR LOCAL
;;------------------------------------------------------------------------------
(defun *error* (msg)
(cond
((not msg)) ; Normal exit
;;Mens in English and Castilian
((member msg '("console break" "Function cancelled" ; <esc> or (quit)
"Función cancelada" "Interrupción desde el teclado" "Interrupción de salida")))
((princ (strcat "\nError CopyBlkAlong: " msg))) ; Fatal error, display it
)
;;Borrar el bloque temporal si se produjo error
;; Delete temporary block if error occurred
(if (and $Blcopy$
(not (vlax-erased-p $Blcopy$)))
(progn
(vl-catch-all-apply (function vla-delete) (list $Blcopy$))
(setq $Blcopy$ nil)
)
);c.if
;;Restart variables
(mapcar (function (lambda (pair)
(setvar (car pair) (eval (car pair)))
(set (car pair) nil)
)) ModVars)
(redraw)
(princ)
);c.defun
;;--------------------------- RoundToNearest -----------------------------------
;; Redondear Numero a Numero mas cercano
;; Round number to the nearest number
;;-------------------------------------------------------------------------------
(defun RoundToNearest (dblVal dblNear / dblTemp Retval)
(if (not (zerop dblNear))
(progn
(setq dblNear (* dblNear 100))
(setq dblTemp (fix (/ (+ (* dblVal (expt 10 2)) (/ dblNear 2)) dblNear)))
(setq RetVal (/ (* dblTemp dblNear) (expt 10 2)))
)
(setq Retval 0)
)
RetVal
);c.defun
;;--------------------------- MoveInteractive -------------------------------------
;; Funcion Principal, Mueve/Copia interactivamente un bloque alolargo de una curva
;; Primary Function, Move / Copy a block interactively alolargo a curve
;;----------------------------------------------------------------------------------
(defun MoveInteractive ( / $blcopy$ ang$ deriv1 dis inp loop
NameBlq param pt pt1 pt2 g1 sx sy tmp$
ChildIncreAng Ang90 angBlk a1
;|Sub|; go:msg Calculos)
;;__________________________________________________________________________________________
(defun Go:Guia ()
(grdraw (trans pCv 0 1)
(trans pt 0 1)
-1
)
(grxPt (trans (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint $Blcopy$))) 0 1) -1)
)
(defun go:msg ()
(princ (strcat "\r[G]uia:" (if $Guia$ "Si" "No")
", [I]ntervalo:" (rtos $Intervalo$ 2)
", [D]istancia:" (rtos Dis 2)
", [+/-][O]ffset:"(rtos $crv-off$ 2)
", [</>][A]ngulo:"(angtos $IncreAng$ 0)
", Click inserta [Exit]:"))
;;(princ (strcat "\r[G]uide:" (if $Guia$ "Si" "No")
;; ", [I]nterval:" (rtos $Intervalo$ 2)
;; ", [D]istance:" (rtos Dis 2)
;; ", [+/-][O]ffset:"(rtos $crv-off$ 2)
;; ", [</>][A]ngle:"(angtos $IncreAng$ 0)
;; ", Click insert [Exit]:"))
)
(defun Calculos (ForceDis)
(setq param (vlax-curve-getParamAtPoint ObjCurve pCv)
deriv1 (vlax-curve-getFirstDeriv ObjCurve param) ;direction vector
pt2 (mapcar '+ pCv deriv1)
angBlk (+ $IncreAng$ (angle pt2 pCv))
)
(setq a1 (cond (ForceDis
(- (angle pCv pt2)(/ pi 2))
)
((angle pCv pt))))
(setq pt1 (vlax-3D-point (polar pCv a1 $crv-off$)))
);c.defun
;;------------------------------ MAIN -----------------------------------------------------
(setq ChildIncreAng (/ pi (/ 180 15.0)) ;;15 grados
Ang90 (/ pi 2.0)) ;;90 grados
(setq xa (angle '(0.0 0.0 0.0)
(trans (getvar 'UCSXDIR) 0 (trans '(0.0 0.0 1.0) 1 0 t))))
;;Datos del Bloque
(setq NameBlq (cdr (assoc 2 (entget ObjBlk)))
Sx (cdr (assoc 41 (entget ObjBlk)))
Sy (cdr (assoc 42 (entget ObjBlk))))
(setq $Blcopy$ (vla-Copy (vlax-ename->vla-object ObjBlk)))
(setq loop T)
;;(print)
(while loop
(setq inp (grread t 15 0)) ; get input, tracking
(setq g1 (car inp) pt (cadr inp)) ; isolate g1 and # or point
(cond
((= (type pt) 'LIST)
(setq pCv (vlax-curve-getClosestPointTo ObjCurve (setq pt (trans pt 1 0))) ;punto en curva
dis (vlax-curve-getDistAtPoint ObjCurve pCv))
(if (not (zerop $Intervalo$))
(progn
(if (> (setq Tmp$ (RoundToNearest dis $Intervalo$)) LongCurve)
(setq dis LongCurve)
(setq dis Tmp$)
)
(cond
((setq pCv (vlax-curve-getPointAtDist ObjCurve Dis)))
((> Dis LongCurve) (setq pCv (vlax-curve-getEndPoint ObjCurve)))
((equal Dis LongCurve 1.0e-004) (setq pCv (vlax-curve-getEndPoint ObjCurve)))
(t (setq pCv (vlax-curve-getStartPoint ObjCurve)))
)
(Calculos t)
);c.prg
(Calculos nil)
);c.if
)
);c.cond
(cond
((= g1 3) ;; "pick" button?
(vla-Copy $Blcopy$)
;(setq loop nil)
)
((= g1 5) ;; tracking point
(go:msg)
;;(COMMAND "_.change" $Blcopy$ pt1 angBlk) ;;NO
(vla-Move $Blcopy$ (vla-get-InsertionPoint $Blcopy$) pt1)
(vla-put-Rotation $Blcopy$ angBlk)
(if $Guia$ (Go:Guia))
(if (and $Guia$ (/= oldG1 5))
(redraw)
)
;;(PRINT $Blcopy$)(PRINC)
)
((and (= g1 2) ;;keyboard
(member pt '(103 71))) ;;key g/G
(setq $Guia$ (not $Guia$))
(redraw)
)
((and (= g1 2)
(member pt '(45 95))) ;; offset -
(setq $crv-off$ (- $crv-off$ $IncreDis$))
)
((and (= g1 2)
(member pt '(43 61))) ;; offset +
(setq $crv-off$ (+ $crv-off$ $IncreDis$))
)
((and (= g1 2)
(member pt '(79 111))) ;; O/o offset
(setq $crv-off$ (cond
((getdist (strcat "\nSpecifique Offset <"
;;"\nSpecify Offset <"
(rtos $crv-off$ 2) ">: ")))
($crv-off$)))
)
((and (= g1 2)
(member pt '(44 60)))
(setq $IncreAng$ (+ $IncreAng$ ChildIncreAng)) ;;>
)
((and (= g1 2)
(member pt '(46 62)))
(setq $IncreAng$ (+ $IncreAng$ (- ChildIncreAng))) ;;<
)
((and (= g1 2) ;;keyboard
(member pt '(65 97))) ;;key a/A
(setq $IncreAng$ (cond
((getangle (strcat "\nAngulo del Bloque;< "
;;"\nAngle Block;< "
(angtos $IncreAng$ 0) " >: ")))
($IncreAng$)))
)
((and (= g1 2) ;keyboard
(member pt '(68 100))) ;Key D/d
(initget "Inicio Fin")
;;(initget "Home End")
(if (setq Tmp$ (getdist (strcat "\nInsertar a distancia o [Inicio/Fin];< "
;;"\nInsert a distance or [Home/End];< "
(rtos Dis 2) " >: ")))
(cond
((= Tmp$ "Inicio" ;|"Home"|;) (setq Dis 0.0))
((= Tmp$ "Fin" ;|"End"|; ) (setq Dis LongCurve))
(T (setq Dis Tmp$))
);c.cond
);c.if
(cond
((setq pCv (vlax-curve-getPointAtDist ObjCurve Dis)))
((> Dis LongCurve)
(prompt (strcat "\nLongitud maxima de curva: ["
;;"\nMaximum length of curve: ["
(rtos LongCurve 2) "].\n"))
(setq pCv (vlax-curve-getEndPoint ObjCurve))
)
((equal Dis LongCurve 1.0e-004)
(prompt (strcat "\nLongitud maxima de curva: ["
;;"\nMaximum length of curve: ["
(rtos LongCurve 2) "].\n"))
(setq pCv (vlax-curve-getEndPoint ObjCurve))
)
(t (setq pCv (vlax-curve-getStartPoint ObjCurve)))
)
(Calculos t)
(vla-Move $Blcopy$ (vla-get-InsertionPoint $Blcopy$) pt1)
(vla-put-Rotation $Blcopy$ angBlk)
(vla-Copy $Blcopy$)
)
((and (= g1 2) ;keyboard
(or (= pt 73)(= pt 105))) ;Key I o i
(initget 4)
(if (setq Tmp$ (getdist (strcat "\nIntervalo entre bloques;< "
;;"\nInterval between blocks;< "
(rtos $Intervalo$ 2) " >: ")))
(if (< Tmp$ LongCurve)
(setq $Intervalo$ Tmp$)
(prompt (strcat "\nIntervalo No Valido, es mayor que la longitud total de curva: ["
;;"\nInvalid range, is greater than the total length of curve:: ["
(rtos LongCurve 2) "].\n"))
);c.if
);c.if
)
((= g1 25) (setq loop nil)) ; button right
(;;(or (and (= g1 6) (= pt 0)) ; button 1, or
(and (= g1 2) ; keyboard and
(or (= pt 13) (= pt 32))) ; CR or blank?
;;);c.or
;(Print "Teclado o cTRL o Espaciadora ")
(setq loop nil) ; exit
)
;(T (setq loop nil)) ; any other grread value ; exit
);c.cond
(setq oldG1 g1)
);c.while
(if (and $Blcopy$
(not (vlax-erased-p $Blcopy$)))
(vla-delete $Blcopy$)
);c.if
);c.defun
;;------------------------------------------------- MAIN -------------------------------------------------------
(setq ModVars
(list '(cmdecho . 0)
'(dimzin . 1)
'(attdia . 0)
'(attreq . 0)
'(snapmode . 0)
'(pickstyle . 0)
(cons 'osmode (boole 7 (getvar 'osmode) 16384))))
(mapcar
(function (lambda (pair)
(set (car pair) (getvar (car pair)))
(setvar (car pair) (cdr pair))
))
ModVars
)
(setq $IncreDis$ 0.1)
;; Variables de documento abiertas
;; Open document Variables
(or $IncreAng$ (setq $IncreAng$ 0))
(or $Intervalo$ (setq $Intervalo$ 0))
(or $crv-off$ (setq $crv-off$ 0.0))
(cond
((not (setq ObjCurve (vl-catch-all-apply (function entsel)(list "Seleccione Curva: " ;|"Select Curve: "|;)))))
((vl-catch-all-error-p ObjCurve))
((not (and (setq ObjCurve (car ObjCurve))
(wcmatch (cdr (assoc 0 (entget ObjCurve))) "SPLINE,ELLIPSE,LINE,ARC,CIRCLE,*POLYLINE")))
(prompt "\nNo ha seleccionado una curva valida.> Spline,Elipse,Linea,Arco,Circulo,Polylinea")
;(prompt "\nYou have not selected a valid curve.> Spline, Ellipse, Line, Arc, Circle or polyline")
)
(T
(cond
((not (setq ObjBlk (vl-catch-all-apply (function entsel)(list "Seleccione Bloque a Insertar: " ;|"Select Block to Insert: "|;)))))
((vl-catch-all-error-p ObjBlk))
((not (and (setq ObjBlk (car ObjBlk))
(wcmatch (cdr (assoc 0 (entget ObjBlk))) "INSERT")))
(prompt "\nNo ha seleccionado un Bloque.")
;;(prompt "\nYou have not selected a Block.")
)
(T
;;Longitud de la curva
(setq LongCurve (vlax-curve-getDistAtParam ObjCurve (vlax-curve-getEndParam ObjCurve))
LongCurve (distof (rtos LongCurve 2 4)))
(if (> $Intervalo$ LongCurve)(setq $Intervalo$ 0.0))
(command "_.UNDO" "_BE")
(grxPt (trans (vlax-curve-getStartPoint ObjCurve) 0 1) 50)
(MoveInteractive)
(redraw)
(command "_.UNDO" "_E")
)
);cond
)
);cond
(*error* nil)
(princ)
);c.defun
(princ)
bernie67- Mensajes : 98
Fecha de inscripción : 22/03/2016
Edad : 56
Localización : Bogota DC-Colombia
Re: Perpendiculares a un eje
O con esta otra rutina puedes hacerlo que es del maestro Luis Dominguez
https://dl.dropboxusercontent.com/u/54898744/DTencad.VLX
Coméntanos si lograste solucionar algo
saludos
Bernardo Corradine
https://dl.dropboxusercontent.com/u/54898744/DTencad.VLX
Coméntanos si lograste solucionar algo
saludos
Bernardo Corradine
bernie67- Mensajes : 98
Fecha de inscripción : 22/03/2016
Edad : 56
Localización : Bogota DC-Colombia
Re: Perpendiculares a un eje
Que tal Bernardo. Gracias por las respuestas. La primera, sólo de verla me abruma, pero al menos lo que pude ver es para colocar un block según vas dando clic en la curva.
La segunda del maestro Domínguez, aunque sí hace lo que necesito, obviamente, no me da la libertad de poder meterle mano. Si no sale nada en un rato, no tendré opción que usarla y espero que "para la siguiente" poder terminar mi rutina. Aunque creo que no habrá mucho tiempo, porque ya amenazaron que "viene mas"
Saludos y gracias
A ver si algún maestro se apiada de mi rutinita para poder terminarla....
La segunda del maestro Domínguez, aunque sí hace lo que necesito, obviamente, no me da la libertad de poder meterle mano. Si no sale nada en un rato, no tendré opción que usarla y espero que "para la siguiente" poder terminar mi rutina. Aunque creo que no habrá mucho tiempo, porque ya amenazaron que "viene mas"
Saludos y gracias
A ver si algún maestro se apiada de mi rutinita para poder terminarla....
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
A ver si te sirve esto de mi profesor Robierzo,
"La distancia mas corte de un punto a una curva es la perpendicular a dicha curva (o línea)"
Un saludo
Disculpame, no había leído la rutina. Con la derivada
No veo en el dwg que es lo que quieres rotular (no me sale ninguna rotulación) y dice que me falta la función mas-en-texto así que no te puedo ayudar mas ....
Otro saludo
"La distancia mas corte de un punto a una curva es la perpendicular a dicha curva (o línea)"
- Código:
(vlax-curve-getclosestpointto obj_vlisp_de_la_curva punto)
Un saludo
Disculpame, no había leído la rutina. Con la derivada
- Código:
(setq slp (vlax-curve-getfirstDeriv ob par))
No veo en el dwg que es lo que quieres rotular (no me sale ninguna rotulación) y dice que me falta la función mas-en-texto así que no te puedo ayudar mas ....
- Código:
(setq marca "marka")
Otro saludo
nolo- Mensajes : 182
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Bueno, me salían los textos agrupados arriba y abajo en la rutina por el osnap.
Yo te recomendaría cambiar los command de textos e inserciones por entmake.
He sustituido mas-en-texto por "mas-en-texto " y creo que es esto lo que buscas
Tercer saludo
Yo te recomendaría cambiar los command de textos e inserciones por entmake.
He sustituido mas-en-texto por "mas-en-texto " y creo que es esto lo que buscas
- Código:
(defun c:cadenas()
(setq old (getvar 'osmode))
(setvar 'cmdecho 0)
(setq marca "marka") <<---- nombre del bloque a insertar como marca del punto
(setq cadena 10)
(if(null (tblobjname "BLOCK" marca))
(progn
(setvar "plinewid" 0.05)
(command "_pline" (list 0 0) (list 0 1)"")
(setq xb (entlast))
(command "_block" marca (list 0 0.5) xb "")
(setvar "plinewid" 0)
))
(vl-cmdf "_undo""_begin")
(while (not (setq eje (car(entsel "\nSelecciona Eje: ")))))
(setq ob(vlax-ename->vla-object eje))
(setq ini(vlax-curve-getstartpoint ob)
fin(vlax-curve-getendpoint ob)
long(vlax-curve-getdistatpoint ob fin)
par(vlax-curve-getParamAtPoint ob fin)
dista 0
punto 0
)
(while(>= long dista)
(setq punto(vlax-curve-getpointatdist ob dista)
par (vlax-curve-getParamAtPoint ob punto)
)
(setq slp (vlax-curve-getfirstDeriv ob par))
(setq ang-rad (angle '(0 0 0) slp) )
(setq ang-grad(/ (* 180 ang-rad )pi )
ang-grad (if (>= (+ 90 ang-grad) 95) (- ang-grad 180) ang-grad)
)
(command "_-insert" marca punto 1 1 ang-grad)
(setq texto(STRCAT "mas-en-texto " (rtos dista 2 2)))
(command "_text" "_C" punto 1.5 (+ 90 ang-grad) texto)
(setq dista(+ cadena dista))
)
(setq punto(polar punto(* 0.5 pi)10))
(command "_text" "_C" punto 2.5 ang-grad (rtos long 2 2))
(vl-cmdf "_undo""_end")
(setvar 'osmode old)
(setvar 'cmdecho 1)
(princ)
)
Tercer saludo
nolo- Mensajes : 182
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Que tal Nolo.
Muchas gracias, es justo lo que buscaba. Dos cosas....
Una disculpa por no subir la rutina "mas-en-texto" como tengo una rutina que carga todas las auxiliares, se me pasó. Aquí la tienes.
Saludos y gracias.
PD. La rutina no es mía, de descargué del foro hace mucho.
Muchas gracias, es justo lo que buscaba. Dos cosas....
Una disculpa por no subir la rutina "mas-en-texto" como tengo una rutina que carga todas las auxiliares, se me pasó. Aquí la tienes.
- Código:
(defun mas-en-texto ( tx / )
(setq ty nil)
(if (distof tx)
(progn
(setq tx (reverse (vl-string->list tx))
cn 0)
(if (member 46 tx)
(progn
(while (/= (car tx) 46)
(setq ty (cons (car tx) ty))
(setq tx (cdr tx))
);_ while
(setq tx (cdr tx) ty (cons 46 ty))
);_ progn
);_ if member 46 , 46 es el chr de . [punto]
(while tx
(if (/= cn 3)
(setq ty (cons (car tx) ty) tx (cdr tx) cn (1+ cn))
(setq ty (cons 43 ty) cn 0)
);_ if cn distinto 3
);_ while tx
(vl-list->string ty)
);_ progn
);_ if tx es un numero escrito como texto
)
Saludos y gracias.
PD. La rutina no es mía, de descargué del foro hace mucho.
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Que tal Nolo....
Intenté ir cambiando los command por entmake.... no resulta como se esperaba, espero tengas oportunidad de verlo.
Aquí te dejo el DWG con los resultados y el nuevo código.
https://dl.dropboxusercontent.com/u/58052688/Drawing4.dwg
Saludos
Intenté ir cambiando los command por entmake.... no resulta como se esperaba, espero tengas oportunidad de verlo.
Aquí te dejo el DWG con los resultados y el nuevo código.
https://dl.dropboxusercontent.com/u/58052688/Drawing4.dwg
Saludos
- Código:
(vl-load-com)
(defun mas-en-texto ( tx / )
(setq ty nil)
(if (distof tx)
(progn(setq tx (reverse (vl-string->list tx))
cn 0)
(if (member 46 tx)
(progn(while (/= (car tx) 46)
(setq ty (cons (car tx) ty))
(setq tx (cdr tx))
);_ while
(setq tx (cdr tx) ty (cons 46 ty)));_ progn
);_ if member 46 , 46 es el chr de . [punto]
(while tx
(if (/= cn 3)
(setq ty (cons (car tx) ty) tx (cdr tx) cn (1+ cn))
(setq ty (cons 43 ty) cn 0)
);_ if cn distinto 3
);_ while tx
(vl-list->string ty));_ progn
);_ if tx es un numero escrito como texto
)
(defun ztx()
(setq cuantos(strlen(itoa dista)))
(cond
((= cuantos 1)(setq texto(strcat "0+00"(rtos dista 2 1))))
((= cuantos 2)(setq texto(strcat "0+0" (rtos dista 2 1))))
((= cuantos 3)(setq texto(strcat "0+" (rtos dista 2 1))))
((> cuantos 3)(setq texto(mas-en-texto (rtos dista 2 1))))
)
(setq escribe
(entmake
(list(cons 0 "TEXT")(cons 10 punto)
(cons 50 (+ 90 ang-grad))
(cons 62 2)
(cons 1 texto) (cons 40 1))))
)
(defun c:cadenas()
(setq old (getvar 'osmode))
(setvar 'cmdecho 0)
(setq marca "marka")
(setq cadena 10)
(if(null (tblobjname "BLOCK" marca))
(progn
;(setvar "plinewid" 0.02)
(setq linea(entmake(list(cons 0 "LINE")(cons 10 (list 0 0))(cons 11 (list 0 8))(cons 62 3))))
;(command "_pline" (list 0 0) (list 0 8)"")
(setq xb (entlast))
(command "_block" marca (list 0 0) xb "")
(setvar "plinewid" 0)
))
(vl-cmdf "_undo""_begin")
(while (not (setq eje (car(entsel "\nSelecciona Eje: ")))))
(setq ob(vlax-ename->vla-object eje))
(setq ini(vlax-curve-getstartpoint ob)
fin(vlax-curve-getendpoint ob)
long(vlax-curve-getdistatpoint ob fin)
par(vlax-curve-getParamAtPoint ob fin)
dista 0
punto 0
)
(while(>= long dista)
(setq punto(vlax-curve-getpointatdist ob dista)
par (vlax-curve-getParamAtPoint ob punto)
)
(setq slp (vlax-curve-getfirstDeriv ob par))
(setq ang-rad (angle '(0 0 0) slp) )
(setq ang-grad(/ (* 180 ang-rad )pi )
ang-grad (if (>= (+ 90 ang-grad) 95) (- ang-grad 180) ang-grad)
)
;
(setq linea(entmake(list(cons 0 "LINE")(cons 10 punto)(cons 11 (polar punto ang-grad 4.5))(cons 62 1))))
(command "_-insert" marca punto 1 1 ang-grad)
(ztx)
;(setq texto(STRCAT "mas-en-texto " (rtos dista 2 2)))
(command "_text" "_C" punto 1 (+ 90 ang-grad) texto)
(setq dista(+ cadena dista))
)
(setq punto(polar punto(* 0.5 pi)10))
(command "_text" "_C" punto 2.5 ang-grad (rtos long 2 2))
(vl-cmdf "_undo""_end")
(setvar 'osmode old)
(setvar 'cmdecho 1)
(princ)
)
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
poner lineas perpendicular al eje
No corresponde, porque el divide y el measure comienzan por el punto mas a la izquierda , no importa el sentido del eje
Última edición por Admin el Jue Jun 02, 2016 9:00 pm, editado 1 vez (Razón : no corresponde)
no sirve
no corresponde
Última edición por Admin el Jue Jun 02, 2016 9:01 pm, editado 1 vez (Razón : no corresponde)
Re: Perpendiculares a un eje
Hola maestro... ya empezaba a pensar que me abandonabas... jajajaja
Mira maestro, como mencioné en el primer post, esto me ayudaron a resolverlo hace ya algún tiempo, por cuestiones que por ahora se me escapan de la memoria, no lo terminé y pues... ya no hay de donde retomarlo, en fin. De lo que si estoy seguro es que en aquella ocasión, se desechó el measure porque representaba "una pasada mas".... entonces, se decidió que fuera con el arcotangente del punto respecto al eje y así matábamos dos o tres pajaros de un tiro...
Lo que pretendo rotular es la distancia, que está en la línea... (command "_text" "_C" punto 1.5 (+ 90 ang-grad) texto)
Ahora, como también mencioné en el último post, al cambiar el command por el entmake, éste no funciona como se espera, seguro que es por el tratamiento del ángulo... en el DWG que anexé, están dos ejes, bueno es uno sólo pero con sentidos opuesto donde se ve el resultado.
Los textos blancos (bien alineados) son con command y los textos amarillos (mal alineados) están con entmake.
Así mismo, inserté la línea verde como un bloque, que en un caso se alinea correctamente a lo largo de un eje y en el otro hay un par de puntos donde se alinean al contrario. Lo mismo me pasó cuando quise sustituír el bloque por líneas simples (las rojas).
La intención de hacerlo así, es porque según el proyecto, a veces se requiere que tanto la línea como el texto estén alineados al centro del eje y en otras, que la línea salga del eje "hacia la derecha" y enseguida se escriba el texto con el cadenamiento.
Espero haya quedado claro.
Saludos y gracias
Mira maestro, como mencioné en el primer post, esto me ayudaron a resolverlo hace ya algún tiempo, por cuestiones que por ahora se me escapan de la memoria, no lo terminé y pues... ya no hay de donde retomarlo, en fin. De lo que si estoy seguro es que en aquella ocasión, se desechó el measure porque representaba "una pasada mas".... entonces, se decidió que fuera con el arcotangente del punto respecto al eje y así matábamos dos o tres pajaros de un tiro...
Lo que pretendo rotular es la distancia, que está en la línea... (command "_text" "_C" punto 1.5 (+ 90 ang-grad) texto)
Ahora, como también mencioné en el último post, al cambiar el command por el entmake, éste no funciona como se espera, seguro que es por el tratamiento del ángulo... en el DWG que anexé, están dos ejes, bueno es uno sólo pero con sentidos opuesto donde se ve el resultado.
Los textos blancos (bien alineados) son con command y los textos amarillos (mal alineados) están con entmake.
Así mismo, inserté la línea verde como un bloque, que en un caso se alinea correctamente a lo largo de un eje y en el otro hay un par de puntos donde se alinean al contrario. Lo mismo me pasó cuando quise sustituír el bloque por líneas simples (las rojas).
La intención de hacerlo así, es porque según el proyecto, a veces se requiere que tanto la línea como el texto estén alineados al centro del eje y en otras, que la línea salga del eje "hacia la derecha" y enseguida se escriba el texto con el cadenamiento.
Espero haya quedado claro.
Saludos y gracias
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
¿¿Es obligatorio que la marca sea un bloque,o puede ser una línea,? y según dices la maraca pude ir a derecha , al centro , o a izquierda mirando desde el inicio -
Re: Perpendiculares a un eje
No maestro, no es obligatorio que sea bloque, puede ser línea. En cuanto a la ubicación: Si la línea es corta, por decir 2 o3, va al centro. Si es larga 5 o más va hacia la derecha, desde el eje saliendo a la derecha. Lo que sí es que el texto debe poderse leer bien.
Saludos y gracias
PD. Es mas, si es línea quedaría mejor ya que se puede orientar el texto con los puntos inicial y final de la línea....
Saludos y gracias
PD. Es mas, si es línea quedaría mejor ya que se puede orientar el texto con los puntos inicial y final de la línea....
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Disculparme, ahora no puedo entrar en detalle pero si funcionaba con el command tiene que funcionar con el entmake
Lo que si se ve a primera vista es que utilizas grados en los entmake cuando Autocad de manera interna (entmake y demás) siempre trabaja en radianes Hay que hacer las comparaciones sobre esa unidad y llevarla al enmake.
Cuando pueda lo miro en detalle
Un salud
Lo que si se ve a primera vista es que utilizas grados en los entmake cuando Autocad de manera interna (entmake y demás) siempre trabaja en radianes Hay que hacer las comparaciones sobre esa unidad y llevarla al enmake.
Cuando pueda lo miro en detalle
Un salud
nolo- Mensajes : 182
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Pues bien.... con una "trampita" pero por ahora hace lo que necesito. Espero que los maestros (Devitg, Nolo y demás) encuentren una oportunidad de revisar mi código, por ahora así funciona, aunque... bueno, está funcionando, jajajaja
Saludos a todos
Saludos a todos
- Código:
(vl-load-com)
(defun mas-en-texto ( tx / )
(setq ty nil)
(if (distof tx)
(progn(setq tx (reverse (vl-string->list tx))
cn 0)
(if (member 46 tx)
(progn(while (/= (car tx) 46)
(setq ty (cons (car tx) ty))
(setq tx (cdr tx))
);_ while
(setq tx (cdr tx) ty (cons 46 ty)));_ progn
);_ if member 46 , 46 es el chr de . [punto]
(while tx
(if (/= cn 3)
(setq ty (cons (car tx) ty) tx (cdr tx) cn (1+ cn))
(setq ty (cons 43 ty) cn 0)
);_ if cn distinto 3
);_ while tx
(vl-list->string ty));_ progn
);_ if tx es un numero escrito como texto
)
(defun xztx()
(setq cuantos(strlen(itoa xdista)))
(cond
((= cuantos 1)(setq texto(strcat "0+00"(rtos xdista 2 0))))
((= cuantos 2)(setq texto(strcat "0+0" (rtos xdista 2 0))))
((= cuantos 3)(setq texto(strcat "0+" (rtos xdista 2 0))))
((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 0))))
)
(setq escribe
(entmake
(list(cons 0 "TEXT")(cons 10 xpunto3)
(cons 50 angulo)
(cons 62 4)
(cons 1 texto) (cons 40 1))))
)
(defun c:pcadenas()
(setvar "osmode" 0)
(setq xdista 0 xcadena 10)
(setq prim(entsel "\n Selecciona el Eje...."))
(setq derecha(getpoint"\Da un click 'A la derecha' Del eje, según el sentido del Cadenamiento..."))
(vl-cmdf "_offset" 1 prim derecha "")
(setq aux(vlax-ename->vla-object(entlast)))
(setq eje(vlax-ename->vla-object(car prim)))
(setq ini(vlax-curve-getstartpoint eje))
(setq xlong(vlax-get eje 'length))
(while(>= xlong xdista)
(setq xpunto1(vlax-curve-getpointatdist eje xdista))
(setq xpunto2(vlax-curve-getclosestpointto aux xpunto1 T))
(setq angulo (angle xpunto1 xpunto2))
(setq xpunto3(polar xpunto1 angulo 8))
(setq linea(entmake(list(cons 0 "LINE")(cons 10 xpunto1)(cons 11 xpunto3)(cons 62 6))))
(xztx)
(setq xdista(+ xcadena xdista))
)
(vla-delete aux))
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Perpendiculares a un eje
Tuviste la misma idea que yo .
se puede hace automático con
y con esto haces el offset según la eleccion
se puede hace automático con
- Código:
(initget 1 "I C D" )
(setq lado (GETKWORD "Izq , Centro, Der (I/C/D) : " ))
y con esto haces el offset según la eleccion
- Código:
(COND ((= LADO "C") (PROGN (SETQ LARGO (/ LARGO-MARCA 2.0)) (SETQ OFF 0)))
((= LADO "D") (PROGN (SETQ LARGO LARGO-MARCA) (SETQ OFF 1)))
((= LADO "I") (PROGN (SETQ LARGO LARGO-MARCA) (SETQ OFF -1)))
(T LARGO-MARCA)
)
);repeat
(IF (NOT (ZEROP OFF))
(PROGN
(SETQ DESPLA (CAR (VAR->LST (VLA-OFFSET EJE-OBJ (* OFF LARGO)))))
(SETQ DESPLA-START (G-STA-PT DESPLA))
)
)
Re: Perpendiculares a un eje
Elias:estoy tratando de modificar tu lisp para colocar progresivas con distancias de 12.5m y centrar el texto
Un Saludo
Luis
- Código:
(vl-load-com)
(defun mas-en-texto ( tx / )
(setq ty nil)
(if (distof tx)
(progn(setq tx (reverse (vl-string->list tx))
cn 0)
(if (member 46 tx)
(progn(while (/= (car tx) 46)
(setq ty (cons (car tx) ty))
(setq tx (cdr tx))
);_ while
(setq tx (cdr tx) ty (cons 46 ty)));_ progn
);_ if member 46 , 46 es el chr de . [punto]
(while tx
(if (/= cn 3)
(setq ty (cons (car tx) ty) tx (cdr tx) cn (1+ cn))
(setq ty (cons 43 ty) cn 0)
);_ if cn distinto 3
);_ while tx
(vl-list->string ty));_ progn
);_ if tx es un numero escrito como texto
)
(defun xztx()
(setq cuantos(strlen(itoa xdista)))
(cond
((= cuantos 1)(setq texto(strcat (rtos xdista 2 1))))
((= cuantos 2)(setq texto(strcat (rtos xdista 2 1))))
((= cuantos 3)(setq texto(strcat (rtos xdista 2 1))))
((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 1))))
;((= cuantos 1)(setq texto(strcat "0+00"(rtos xdista 2 0))))
;((= cuantos 2)(setq texto(strcat "0+0" (rtos xdista 2 0))))
;((= cuantos 3)(setq texto(strcat "0+" (rtos xdista 2 0))))
;((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 0))))
)
(setq escribe
(entmake
(list(cons 0 "TEXT")(cons 10 xpunto3)
(cons 50 angulo)
(cons 62 4)
(cons 1 texto) (cons 40 0.5))));Altura del Texto:0.5
)
(defun c:pcadenas()
(setvar "osmode" 0)
(setq xdista 0 xcadena 12.5);Coloca Las Distancias del Inicio
(setq prim(entsel "\n Selecciona el Eje...."))
(setq derecha(getpoint"\Da un click 'A la derecha' Del eje, según el sentido del Cadenamiento..."))
(vl-cmdf "_offset" 1 prim derecha "")
(setq aux(vlax-ename->vla-object(entlast)))
(setq eje(vlax-ename->vla-object(car prim)))
(setq ini(vlax-curve-getstartpoint eje))
(setq xlong(vlax-get eje 'length))
(while(>= xlong xdista)
(setq xpunto1(vlax-curve-getpointatdist eje xdista))
(setq xpunto2(vlax-curve-getclosestpointto aux xpunto1 T))
(setq angulo (angle xpunto1 xpunto2))
(setq xpunto3(polar xpunto1 angulo 2));Distancia de la Linea Recta :2
(setq linea(entmake(list(cons 0 "LINE")(cons 10 xpunto1)(cons 11 xpunto3)(cons 62 6))))
(xztx)
(setq xdista(+ xcadena xdista))
)
(vla-delete aux))
eliasp
Mensajes : 26
Fecha de inscripción : 17/03/2016
Ver perfil de usuario
;;;oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
oooooooooooooooooo
(textpage);Para ver en Cuadro de Texto
(princ "\n:: Comando: \"PCADENAS\" para Ejecutar")
(princ)
Un Saludo
Luis
Luis Alberto Benitez- Mensajes : 112
Fecha de inscripción : 29/03/2016
Re: Perpendiculares a un eje
Que error te da , copia de la pantalla de texto . Usas el VLIDE??
Lo que pasa es que tu distancia es un REAL , entonce no funciona el
EN LA DEFUN
Y no sé si va a funcionar con
Lo que pasa es que tu distancia es un REAL , entonce no funciona el
- Código:
(setq cuantos(strlen(itoa xdista)))
EN LA DEFUN
- Código:
(defun xztx()
Y no sé si va a funcionar con
- Código:
(setq cuantos(strlen(RTOS xdista)))
Última edición por Admin el Vie Jun 03, 2016 11:39 pm, editado 1 vez
Re: Perpendiculares a un eje
Maestro Gracias por Responder.
El mensaje de error es el Siguiente:
Comando: ; error: tipo de argumento erróneo: fixnump: 12.5
El mensaje de error es el Siguiente:
Comando: ; error: tipo de argumento erróneo: fixnump: 12.5
Luis Alberto Benitez- Mensajes : 112
Fecha de inscripción : 29/03/2016
Re: Perpendiculares a un eje
Luis Alberto Benitez escribió:Maestro Gracias por Responder.
El mensaje de error es el Siguiente:
Comando: ; error: tipo de argumento erróneo: fixnump: 12.5
Ve mi mensaje anterio, y sí funciona , el problema es que quire hacer ITOA a un REAL , y debe usar RTOS
va imagen
Va corregido
- Código:
(defun xztx()
(setq cuantos(strlen(RTOS xdista)))
(cond
((= cuantos 1)(setq texto(strcat (rtos xdista 2 1))))
((= cuantos 2)(setq texto(strcat (rtos xdista 2 1))))
((= cuantos 3)(setq texto(strcat (rtos xdista 2 1))))
((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 1))))
;((= cuantos 1)(setq texto(strcat "0+00"(rtos xdista 2 0))))
;((= cuantos 2)(setq texto(strcat "0+0" (rtos xdista 2 0))))
;((= cuantos 3)(setq texto(strcat "0+" (rtos xdista 2 0))))
;((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 0))))
)
(setq escribe
(entmake
(list(cons 0 "TEXT")(cons 10 xpunto3)
(cons 50 angulo)
(cons 62 4)
(cons 1 texto) (cons 40 0.5))));Altura del Texto:0.5
)
Re: Perpendiculares a un eje
Gracias por la pronta Respuesta a la Requisitoria el lisp funciona Perfectamente
para colocar las Progresivas, lo que faltaría seria centrar el Texto pero ya es mucho pedir.
Un Saludo
Luis
para colocar las Progresivas, lo que faltaría seria centrar el Texto pero ya es mucho pedir.
Un Saludo
Luis
Luis Alberto Benitez- Mensajes : 112
Fecha de inscripción : 29/03/2016
Re: Perpendiculares a un eje
Digo Centrar el texto con la Linea.
Luis Alberto Benitez- Mensajes : 112
Fecha de inscripción : 29/03/2016
texto con just centrado en el extremo de lalinea
Luis Alberto Benitez escribió:Digo Centrar el texto con la Linea.
Bueno ya corregimos el error , ahora el texto debe ir centrado en la linea , o centrado en el punto final??
- Código:
(DEFUN XZTX ()
(SETQ CUANTOS (STRLEN (RTOS XDISTA)))
(COND
((= CUANTOS 1) (SETQ TEXTO (STRCAT (RTOS XDISTA 2 1))))
((= CUANTOS 2) (SETQ TEXTO (STRCAT (RTOS XDISTA 2 1))))
((= CUANTOS 3) (SETQ TEXTO (STRCAT (RTOS XDISTA 2 1))))
((> CUANTOS 3) (SETQ TEXTO (MAS-EN-TEXTO (RTOS XDISTA 2 1))))
;((= cuantos 1)(setq texto(strcat "0+00"(rtos xdista 2 0))))
;((= cuantos 2)(setq texto(strcat "0+0" (rtos xdista 2 0))))
;((= cuantos 3)(setq texto(strcat "0+" (rtos xdista 2 0))))
;((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 0))))
)
(SETQ ESCRIBE
(ENTMAKE
(LIST (CONS 0 "TEXT")
(CONS 10 XPUNTO3)
(CONS 50 ANGULO)
(CONS 62 4)
(CONS 1 TEXTO)
(CONS 40 0.5) ;Altura del Texto:0.5
); fin list
);fin entmake
);fin escribe
(setq texto-obj (vlax-ename->vla-object (entlast)))
(VLA-PUT-ALIGNMENT texto-obj acAlignmentCenter)
(VLA-PUT-TEXTALIGNMENTPOINT texto-obj (VLAX-3D-POINT XPUNTO3 ))
)
Re: Perpendiculares a un eje
Para centrarlo en la linea cambia todo la defun XZTX
- Código:
(DEFUN XZTX ()
(SETQ CUANTOS (STRLEN (RTOS XDISTA)))
(COND
((= CUANTOS 1) (SETQ TEXTO (STRCAT (RTOS XDISTA 2 1))))
((= CUANTOS 2) (SETQ TEXTO (STRCAT (RTOS XDISTA 2 1))))
((= CUANTOS 3) (SETQ TEXTO (STRCAT (RTOS XDISTA 2 1))))
((> CUANTOS 3) (SETQ TEXTO (MAS-EN-TEXTO (RTOS XDISTA 2 1))))
;((= cuantos 1)(setq texto(strcat "0+00"(rtos xdista 2 0))))
;((= cuantos 2)(setq texto(strcat "0+0" (rtos xdista 2 0))))
;((= cuantos 3)(setq texto(strcat "0+" (rtos xdista 2 0))))
;((> cuantos 3)(setq texto(mas-en-texto (rtos xdista 2 0))))
)
(SETQ ESCRIBE
(ENTMAKE
(LIST (CONS 0 "TEXT")
(CONS 10 xpunto2)
(CONS 50 ANGULO)
(CONS 62 4)
(CONS 1 TEXTO)
(CONS 40 0.5) ;Altura del Texto:0.5
); fin list
);fin entmake
);fin escribe
(setq texto-obj (vlax-ename->vla-object (entlast)))
(VLA-PUT-ALIGNMENT texto-obj acAlignmentCenter)
(VLA-PUT-TEXTALIGNMENTPOINT texto-obj (VLAX-3D-POINT XPUNTO2 ))
);_ fin defun xztx
Página 1 de 2. • 1, 2
Página 1 de 2.
Permisos de este foro:
No puedes responder a temas en este foro.
|
|