acad hispano
¿Quieres reaccionar a este mensaje? Regístrate en el foro con unos pocos clics o inicia sesión para continuar.

Perpendiculares a un eje

+2
bernie67
eliasp
6 participantes

Página 2 de 2. Precedente  1, 2

Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Sáb Jun 04, 2016 12:34 am

Lo que quise decir es Centrar con el Final de la Linea

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Sáb Jun 04, 2016 1:30 am

La solución se dio de la siguiente Manera:
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-ALIGNMENT  texto-obj acAlignmentCenter)
;(VLA-PUT-ALIGNMENT  texto-obj acAlignmentMiddleCenter)
(VLA-PUT-ALIGNMENT  texto-obj acAlignmentMiddleLeft)


  (VLA-PUT-TEXTALIGNMENTPOINT texto-obj (VLAX-3D-POINT XPUNTO3 ))

  )
Gracias Maestro por todos los Aportes a fin de solucionar el Tema.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por devitg Sáb Jun 04, 2016 1:48 am

Bien , me alegro haber ayudado, lástima que no fuiste muy claro en el pedido. Una simple imagen ahorraría mucho tiempo.
Es el error mas veces cometido por quienes pregunta.
Ya llevo mas de 12 años contestando en los foros, y siempre el pedido no es completo.
En este tema NO SE DEBE DAR NADA POR ENTENDIDO.
Pero no importa a mí me encanta hacer esto .

devitg
Admin

Mensajes : 257
Fecha de inscripción : 16/03/2016
Edad : 75
Localización : CORDOBA ARGENTINA

https://acadhispano.foroargentina.net

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Dom Jun 05, 2016 4:37 pm

Aquí encontré un lisp de Hispacad Cuyo Autor es Jose L. García G.
Que coloca la Distancia en forma Dinámica lo que quiero es sacar los ceros
de la Izquierda y sin decimales.
Código:
;;; _  _  _                               _  
;;; | || |(_) ___ _ __  __ _  __  __ _  __| |
;;; | __ || |(_-<| '_ \/ _` |/ _|/ _` |/ _` |
;;; |_||_||_|/__/| .__/\__,_|\__|\__,_|\__,_|
;;;             |_|                          
;;;     www.Hispacad.com                          

;;; OPR.LSP V.2 - 2/10/13

; Cargar las funciones ActiveX (Visual Lisp)
(vl-load-com)


;;---------------------------- Num2StrPK -------------------------------------
;; Convierte un numero en cadena de tipo P.K. (0+000.000)                    
;; Jose L. García G. - Hispacad.com                                          
;;----------------------------------------------------------------------------
(defun Num2StrPK (num AddPK / Negativo num$ dZim pk1 pk2 RetVal posD Entero l Decim)
 (setq dZim (getvar "dimzin"))
 (setvar "dimzin" 1)
 (setq num$ (rtos num 2 (getvar "luprec")))
 (setvar "dimzin" dZim)
 (if (minusp num)
  (setq num$ (substr num$ 2) Negativo T)
 )
 (setq posD (vl-string-search "." num$)
       Entero (substr num$ 1 posD)
       Decim  (substr num$ (+ posD 2))
        
       l      (strlen Entero))
 (if (> l 3)
  (setq pk1 (substr Entero 1 (- l 3))
   pk2 (substr Entero (- l 2))
   RetVal (strcat pk1 "+" pk2))
    

  (progn
   (setq pk1 Entero)
   (repeat (- 3 l)(setq pk1 (strcat "0" pk1)))
   ;(setq RetVal (strcat "0+" pk1));Coloca el signo "+"
    (setq RetVal (strcat pk1))

  );c.prg
 );c.if
 (if (and Decim (/= (atoi Decim) 0))
  (setq RetVal (strcat RetVal "." Decim))
 );c.if
 (if Negativo
  (setq RetVal (strcat "-" RetVal))
 );c.if
 (if AddPK (setq RetVal (strcat "P.K. " RetVal)))
 RetVal
)
;;------------------------ ObjPt2VectTan -----------------------------
;;Obtiene el segmento tangente a un objeto mediante un punto.        
;;Jose L. García G. - Hispacad.com                                    
;;--------------------------------------------------------------------
(defun ObjPt2VectTan (vobj pnt / param p1 p2 deriv1)
 (setq p1 (vlax-curve-getClosestPointTo vobj (trans pnt 1 0));punto en curva
       param (vlax-curve-getParamAtPoint vobj p1)
       deriv1 (vlax-curve-getFirstDeriv vobj param)    ;vector de direccion No point
       p2 (mapcar '+ p1 deriv1))
 (if (and p1 p2) (list p1 p2))
);c.defun

;;______________________________________________________________________
(defun PtPerpToVec (ptCheck p1 p2 / 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)
)
;;----------------------- grdx -------------------------------------
; X en pantalla                                                    
;;Jose L. García G. - Hispacad.com                                  
;;------------------------------------------------------------------
(defun 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)
);c.defun


;;======================================== C:OPR1 ==============================================
;;==============================================================================================
;; Localizar y marcar prograsivas en Curva (polilinea, spline,...)                              
;; Jose L. García G. - Hispacad.com  08/02/2013                                                
;;==============================================================================================
;;==============================================================================================
(defun C:OPR1 ( / ChangeInic oCurve Tmp Punprog LongInEje len hlen DatTangent
         PtPick AngPerp PtAux PtSel oText NewPt PtTxt
         ;|Var OPCIONES|; $CenterTxt$ $HTxt$ $FijarDist$ $DrawLine$ $DrawLineEje$ $ColTxt$ $ColLineRef$ $ColLineEje$
         ;|Especific functions|; OPR:Draw_Txt OPR:Draw_Line *error* grd> OPR:MoveText)
        ;;__________________________________________________________
 ;;funcion de ERROR Interna
 (defun *error* (msg)
 (print (strcat "OPR Error: " msg))
 )
 ;;--------------------- OPR:Draw_Txt -------------------------
 ;; dibuja sTexto                                              
 ;;------------------------------------------------------------
 (defun OPR:Draw_Txt (p al ang cad codh codv col)
 (entmakex (list '(0 . "TEXT")
 (cons 62 col)
 (cons 40 al)
 (cons 1 cad)
 (cons 50 ang)
 '(41 . 1.0)
 (cons 72 codh)
 (cons 10 p)
 (cons 11 p)
 (cons 73 codv)
 );c.list
 );c.entmk
 );c.defun
        ;;--------------------- OPR:Draw_Line ---------------------------
 ;; dibuja linea                                              
 ;;-----------------------------------------------------------
        (defun OPR:Draw_Line ( p1 p2 col / )
 (entmake (list '(0 . "LINE") (cons 62 col) (cons 10 p1)(cons 11 p2)))
 )
 ;;----------------------- grd> -------------------------------------
 ; > en pantalla                                                    
 ;;Jose L. García G. - Hispacad.com                                  
 ;;------------------------------------------------------------------
 (defun grd> (oCurve p col size Invert / Aux DatTangent h p1 p2)
 (setq DatTangent (ObjPt2VectTan oCurve p))
 (setq p  (car DatTangent)
       Ang (apply 'angle DatTangent))
 (setq Aux (if Invert 0 pi))
 (setq h (/ (getvar "viewsize") size))
 (setq p1 (polar p (+ (- ang Aux) (/ pi 9)) h)
       p2 (polar p (- (- ang Aux) (/ pi 9)) h))
 (grdraw (trans p 0 1) (trans p1 0 1) col 0)
 (grdraw (trans p 0 1) (trans p2 0 1) col 0)
 );c.defun
 ;;--------------------------- OPR:MoveText -----------------------------------------
 ;;Mover el sTexto Elasticamente en pantalla                                        
 ;;----------------------------------------------------------------------------------
 (defun OPR:MoveText ( ;|oText oCurve PtPick AngPerp|; / PtOld flag gr1 gr2 xa )
 (setq PtOld PtPick
       NewPt nil)
 (while
  (progn (setq gr (grread t 15 0) gr1 (car gr) gr2 (cadr gr))
   (cond
     ;; 5 tracking point  ;; 3 "pick" button?
    ((member gr1 '(5 3)) ;;Punto
     (cond
      (NewPt
       (princ (strcat "\r>>Distancia:[" (rtos (if (> $FijarDist$ 0)
 $FijarDist$
 (distance PtPick NewPt)) 2)
  "]; Indique lado: "))
       ;;Borra la linea elástica anterior
       (grdraw (trans PtPick 0 1) (trans NewPt 0 1) -1 -1)
       (setq PtOld NewPt)
      )
     );c.cond
     (setq PtAux (polar PtPick AngPerp 1.0))
     (setq NewPt (PtPerpToVec (trans gr2 1 0) PtPick PtAux))
     (if (> $FijarDist$ 0)
      (setq NewPt (polar PtPick (angle PtPick NewPt) $FijarDist$))
     )
     (grdraw (trans PtPick 0 1) (trans NewPt 0 1) -1 -1)
     (vla-put-Rotation oText (angle PtPick NewPt))
     (if (and $DrawLineRef$ (not $CenterTxt$))
      (vla-put-Alignment oText acAlignmentBottomRight)
      (vla-put-Alignment oText acAlignmentMiddleLeft)
     ;; acAlignmentBottomLeft acAlignmentBottomCenter acAlignmentBottomRight
     )
     (vla-move oText (vlax-3D-point PtOld)(vlax-3D-point NewPt))
    
     (null (setq flag (= gr1 3)))
    )
    ((= 25 gr1)
     nil
    )
    ((= 02 gr1);;Keys
     (cond
      ((member gr2 '(13 32))   ;; Enter/Space
       nil
      )
      ;;(t (princ (strcat "\nTecla no valida.")))
     )
    )
    );c.cond
   );c.Prg
  );c.if
 flag
 );c.defun
 
 ;;---------------------------- MAIN ----------------------------------------
 ;;OPCIONES:                              
 ;;Fijar una distancia para el texto:      
 ;; [< 0  = Mover Elástico]                
 ;; [> 0  = indicar solo de lado Curva]    
 ;; [= 0 no mover] fijar en punto indicado
 (setq $FijarDist$ -1)
 ;.................................
 ;;Altura y color de Texto:
 (setq $HTxt$ (getvar "TEXTSIZE"))
 (setq $ColTxt$ 6)
 (setq $CenterTxt$ nil)
 ;;Dibujar linea de referencia:
 (setq $DrawLineRef$ t)
 (setq $ColLineRef$ 4)

 ;;Dibujar linea en el Eje
 (setq $DrawLineEje$ T)
 (setq $LenLineEje$ 3.0)
 (setq $ColLineEje$ 2)
 
 (if (not *ProgDef*)(setq *ProgDef* 0.0))
 (setq ChangeInic "No")
 (cond
  ((not (setq oCurve (entsel "\nSeleccione Eje: ")))
   (prompt "\nNo ha seleccionado Eje: (polilinea, línea, spline,..)")
  )
  (T
   (setq PtSel  (cadr oCurve)
 oCurve (car oCurve))
   (grd> oCurve PtSel 1 25 nil)
   (initget "Si No")
   (if (setq Tmp (getkword "\nCambiar inicio del Eje [Si/No] <No>: "))
    (progn
     (setq ChangeInic Tmp)
     (redraw)
     (grd> oCurve PtSel 2 25 t)
    )
   );c.if
   (initget 0)
   (if (setq Tmp (getreal (strcat "\nProgresiva inicial del Eje <" (rtos *ProgDef* 2) ">: ")))
    (setq *ProgDef* Tmp)
   )
   (while
    (setq Punprog (getpoint "\nIndique el punto en Eje: "))
    (setq LongInEje (vlax-curve-getDistAtPoint oCurve
     (vlax-curve-getClosestPointTo oCurve (trans Punprog 1 0))))
    (if (= ChangeInic "No")
     (setq param (vlax-curve-GetStartParam oCurve))
     (setq param (vlax-curve-GetEndParam oCurve))
    )
    (setq len (vlax-curve-getDistAtParam oCurve param))
    (if (= ChangeInic "No")
      (setq hlen (+ len LongInEje))
      (setq hlen (- len LongInEje))
    )
    (cond
     ((not hlen)
      (prompt "\nError: No se pudieron obtener datos del punto indicado.")
     )
     ((setq DatTangent (ObjPt2VectTan oCurve Punprog))
      (vl-cmdf "_.undo" "_BE")
      (setq PtPick  (car DatTangent))
      (setq AngPerp (apply (if (= ChangeInic "No") '- '+) (list (apply 'angle DatTangent) (/ pi 2))))
      (setq PtAux   (polar PtPick AngPerp 1.0))
      (grdx (trans PtPick 0 1) 211 120)
      ;;Format Text:
      (setq sTexto (Num2StrPK (+ *ProgDef* hlen) nil))
      (cond
       ((zerop $FijarDist$) ;;Distancia fijada en 0
 (setq NewPt PtPick)
 (setq oText (OPR:Draw_Txt PtPick $HTxt$ (angle PtPick PtAux) sTexto 1 1 $ColTxt$))
       )
       (t
 (setq oText (OPR:Draw_Txt PtPick $HTxt$ (angle PtPick PtAux) sTexto 0 2 $ColTxt$)
      oText (vlax-ename->vla-object oText))
 (cond
 ((or (vl-catch-all-error-p (setq MoveText (vl-catch-all-apply (function OPR:MoveText))))
      (not MoveText))
  (vla-delete oText)
  (redraw)
 )
 );c.cond
       )
      );c.cond
      (cond
       ((and oText (not (vlax-erased-p oText)))
 ;;Draw Line Eje:
 (if $DrawLineEje$  
 (OPR:Draw_Line (polar PtPick AngPerp (/ $LenLineEje$ 2.0))
            (polar PtPick (+ AngPerp pi) (/ $LenLineEje$ 2.0))
            $ColLineEje$)
 );c.if
 (cond
 ((and $DrawLineRef$
       (not (zerop $FijarDist$))
       (> (distance PtPick NewPt) $HTxt$))
  (if $CenterTxt$ (setq NewPt (polar NewPt (angle NewPt PtPick) (/ $HTxt$ 2.0))))
  (OPR:Draw_Line PtPick NewPt $ColLineRef$)
 )
 )
 (redraw)
 (vl-cmdf "_.undo" "_E")
       )
      );c.cond
     )
    );c.cond
   );;c.while
  );T
 );c.cond
(princ)
)

(princ)

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty COMO SIEMPRE Y NO POR ÚLTIMA VES

Mensaje por devitg Dom Jun 05, 2016 5:55 pm

Tu Pedido

Código:
lo que quiero es sacar los ceros
de la Izquierda y sin decimales.


Por favor y no por última ves, SUBE EL DWG DONDE QUIERES APLICARLO Y LA FORMA COMO QUIERES EL TEXTO

Mi mail devitg@gmail.com

devitg
Admin

Mensajes : 257
Fecha de inscripción : 16/03/2016
Edad : 75
Localización : CORDOBA ARGENTINA

https://acadhispano.foroargentina.net

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por devitg Dom Jun 05, 2016 6:17 pm


DE todos modos hay que jugar con esta parte de código

Código:
(defun Num2StrPK (num AddPK / Negativo num$ dZim pk1 pk2 RetVal posD Entero l Decim)
 (setq dZim (getvar "dimzin"))
 (setvar "dimzin" 1)
 (setq num$ (rtos num 2 (getvar "luprec")))
 (setvar "dimzin" dZim)
 (if (minusp num)
  (setq num$ (substr num$ 2) Negativo T)
 )
 (setq posD (vl-string-search "." num$)
      Entero (substr num$ 1 posD)
      Decim  (substr num$ (+ posD 2))
       
      l      (strlen Entero))
 (if (> l 3)
  (setq pk1 (substr Entero 1 (- l 3))
  pk2 (substr Entero (- l 2))
  RetVal (strcat pk1 "+" pk2))
   

  (progn
  (setq pk1 Entero)
  (repeat (- 3 l)(setq pk1 (strcat "0" pk1)))
  ;(setq RetVal (strcat "0+" pk1));Coloca el signo "+"
    (setq RetVal (strcat pk1))

  );c.prg
 );c.if
 (if (and Decim (/= (atoi Decim) 0))
  (setq RetVal (strcat RetVal "." Decim))
 );c.if
 (if Negativo
  (setq RetVal (strcat "-" RetVal))
 );c.if
 (if AddPK (setq RetVal (strcat "P.K. " RetVal)))
 RetVal
)


Los argumentos de esta defun , son : l
la longitud , y un T para que agregue PK , o nil para que no lo agregue .

No sé que valores puede tener tus longitudes .




devitg
Admin

Mensajes : 257
Fecha de inscripción : 16/03/2016
Edad : 75
Localización : CORDOBA ARGENTINA

https://acadhispano.foroargentina.net

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Dom Jun 05, 2016 10:34 pm

Los valores de Longitud son de 0 a 10000.
Lo que no consigo es que los valores de la distancia
sean con valores sin decimales Ej: 12000.25 a 12000
Como siempre gracias por los Aportes.

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Creo que te confundiste en el primer mensaje.

Mensaje por devitg Dom Jun 05, 2016 11:09 pm

En tu primer mensaje pusiste

Que coloca la Distancia en forma Dinámica lo que quiero es sacar los ceros
de la Izquierda y sin decimales.




Luis Alberto Benitez escribió:Los valores de Longitud son de 0 a 10000.
Lo que no consigo es que los valores de la distancia
sean con valores sin decimales Ej: 12000.25 a 12000
Como siempre gracias por los Aportes.

Y ahora resultan que quieres los de la DERECHA


Me recuerda un cuentito o chiste.

La paciente del dentista dice
Dr NO SE QUE PREFIERO: SI SACARME UNA MUELA O TENER UN HIJO.
a lo que el dentista le dice :
BUENO SRA , DECÍDASE , ASÍ SÉ CÓMO ACOMODAR EL SILLON.



Cambia toda la defun   NUM2STRPK , por


Código:
(DEFUN NUM2STRPK  (NUM
                   ADDPK
                   /
 NUM$ RETVAL
                   )

(setq addpk nil)
  (SETQ NUM$ (ITOA (FIX NUM)))

  (SETQ RETVAL NUM$)
  ) ; -fin Num2StrPK



devitg
Admin

Mensajes : 257
Fecha de inscripción : 16/03/2016
Edad : 75
Localización : CORDOBA ARGENTINA

https://acadhispano.foroargentina.net

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Lun Jun 06, 2016 12:13 am

La interpretación ya lo verás en el DWG que envié lo mismo la parte de Redondeo
de los Valores.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Lun Jun 06, 2016 12:53 am

La Solución que encontré fue la Siguiente:
Código:
(DEFUN NUM2STRPK  (NUM
                  ADDPK
                  /
 NUM$ RETVAL
                  )

(setq addpk nil)
  ;(SETQ NUM$ (ITOA (FIX NUM)))
  (SETQ NUM$ (RTOS NUM 2 0))

  (SETQ RETVAL NUM$)
  ) ; -fin Num2StrPK

Gracias al Maestro por guiarme a Buscar la Misma.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por devitg Lun Jun 06, 2016 1:05 am

Esta puede ser otra opción



Código:
(DEFUN NUM2STRPK  (NUM
                  ADDPK
                  /
 NUM$ RETVAL DECIMAL
                  )

(setq decimal ( - num (fix num)))
(if 
  ( > decimal 0.5)
  (setq num (1+ (fix num)))
  (setq num  (fix num))
)
     
                             
  (SETQ NUM$ (ITOA NUM))

  (SETQ RETVAL NUM$)
  ) ; -fin Num2StrPK





devitg
Admin

Mensajes : 257
Fecha de inscripción : 16/03/2016
Edad : 75
Localización : CORDOBA ARGENTINA

https://acadhispano.foroargentina.net

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Jue Jun 09, 2016 3:09 am

Quiero seguir modificando el lisp para que me de el texto del mismo lado
inferior como superior pero no se como, si me pueden ayudar muy agradecido.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Dominguez Vie Jun 24, 2016 11:57 am

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??

Para centrar el texto quiza os valga esta rutina
Código:
; Cadenamiento en tiempo real moviendo el puntero.
; Luis Dominguez Gomez ©2013
;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
;; convierte texto decimal en imperial
(defun imper (nmr / tk tu res frc)
  (setq tk (fix (/ nmr 1000)))
  (setq tu (if (= tk 0)
             nmr
             (rem nmr (* tk 1000))
           )
  )
  (setq frc (if (> (- tu (fix tu)) 0.005)
              3
              0
            )
  )
  (if (< tu 100)
    (setq res (strcat (if (< tu 10)
                        "00"
                        "0"
                      )
                      (rtos tu 2 frc)
              )
    )
    (setq res (rtos tu 2 frc))
  )
  (strcat (rtos tk 2 0) "+" res)
)
;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
;cadenamiento en tiempo real
(defun c:cetr (/ lay gr ptins len enti mtext ptinpl text altxt inic angu tang)
  (vl-load-com)
  (if (not (tblobjname "LAYER" "CADENAMIENTO"))
    (entmake (list '(0 . "LAYER") '(5 . "30") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   '(2 . "CADENAMIENTO") '(70 . 0) '(62 . 1) '(6 . "Continuous") '(290 . 1) '(370 . -3)
                  )
    )
  )
  (setq lay (getvar 'clayer))
  (setvar 'clayer "CADENAMIENTO")
  (setq enti (car (entsel "\nSelecciona poly: ")))
  (setq inic (getreal "\nValor de inicio: "))
  (setq altxt (getvar 'textsize))
  (princ "\n[+]Agranda texto, [-]Reduce texto: ")
  (while (and (setq gr (grread t 11)) (/= (car gr) 3))
    (cond ((equal gr '(2 43)) (setq altxt (+ altxt 0.5)))
          ((equal gr '(2 45)) (setq altxt (- altxt 0.5)))
          ((equal (car gr) 5)
           (setq ptinpl (vlax-curve-getclosestpointto enti (trans (cadr gr) 1 0)))
           (setq len (vlax-curve-getdistatpoint enti ptinpl))
           (setq tang (vlax-curve-getfirstderiv enti (vlax-curve-getparamatdist enti len)))
           (setq angu (atan (cadr tang) (car tang)))
           (setq text (rtos (+ inic len) 2 3)) ; decimal
;;;           (setq text (imper (+ inic len))); imperial
           (setq ptins (vlax-3d-point ptinpl))
           (if mtext
             (progn (vla-put-textstring mtext text) (vla-put-insertionpoint mtext ptins))
             (setq
               mtext (vla-addmtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) ptins 3 text)
             )
           )
           (vla-put-height mtext altxt)
           (vla-put-rotation mtext (- angu (/ pi 2)))
           (vla-put-layer mtext "CADENAMIENTO")
           (vla-put-attachmentpoint mtext acattachmentpointbottomleft)
          )
    )
  )
  (vl-cmdf "_move" (entlast) "" ptinpl (polar ptinpl (- angu (/ pi 2.5)) altxt))
  (vl-cmdf "_line" ptinpl (polar ptinpl (- angu (/ pi 2)) (* altxt (strlen text))) "")
  (setvar 'clayer lay)
  (prin1)
)
;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
Un sañudo
Dominguez
Dominguez

Mensajes : 151
Fecha de inscripción : 20/03/2016
Edad : 74
Localización : Zaragoza (España)

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Sáb Jun 25, 2016 1:54 am

Dominguez Gracias por el aporte este es mas dinámico ya que va realizando el cambio de las distancias en forma de que uno va moviéndose a lo largo de la polilinea, la alineación del texto bien se podría aplicar referencia a objeto.
Un Saludo
Luis

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Luis Alberto Benitez Dom Jun 26, 2016 4:03 pm

Dominguez:
Aquí realice las modificaciones de acuerdo a mis necesidades espero le sirva a algunos
Código:
; Cadenamiento en tiempo real moviendo el puntero.
; Luis Dominguez Gomez ©2013
;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
;; convierte texto decimal en imperial
(defun imper (nmr / tk tu res frc)
  (setq tk (fix (/ nmr 1000)))
  (setq tu (if (= tk 0)
             nmr
             (rem nmr (* tk 1000))
           )
  )
  (setq frc (if (> (- tu (fix tu)) 0.005)
              3
              0
            )
  )
  (if (< tu 100)
    (setq res (strcat (if (< tu 10)
                        "00"
                        "0"
                      )
                      (rtos tu 2 frc)
              )
    )
    (setq res (rtos tu 2 frc))
  )
  (strcat (rtos tk 2 0) "+" res)
)
;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
;cadenamiento en tiempo real
(defun c:cetr (/ lay gr ptins len enti mtext ptinpl text altxt inic angu tang)
  (vl-load-com)
  (if (not (tblobjname "LAYER" "CADENAMIENTO"))
    (entmake (list '(0 . "LAYER") '(5 . "30") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   '(2 . "CADENAMIENTO") '(70 . 0) '(62 . 1) '(6 . "Continuous") '(290 . 1) '(370 . -3)
                  )
    )
  )
  (setq lay (getvar 'clayer))
  (setvar 'clayer "CADENAMIENTO")
  (setq enti (car (entsel "\nSeleccionar Eje: ")))

(TERPRI)
(PRINC "\nColocar Valor de Inicio   ")
(TERPRI)
(setq cmdact0 (getvar "cmdactive"))
(PRINC "\nValor de Inicio:")
(if (not linep_in0) (setq linep_in0 0))
(if (setq inic (getreal (strcat "\nValor de Inicio: <"(rtos linep_in0)">:")))
(setq linep_in0 in)
(setq in linep_in0)
)
(TERPRI)


  ;(setq inic (getreal "\nValor de Inicio: "))
  (setq altxt (getvar 'textsize))
  (princ "\n[+]Agranda Texto, [-]Reduce Texto: ")
(setvar "CMDECHO" 0)
(command "orto""DES")
(SETVAR "OSMODE" 0)
(SETVAR "OSMODE" 512);Cercano
;(SETVAR "OSMODE" 1);Punto Final
;(SETVAR "OSMODE" 32);Interseccion

  (while (and (setq gr (grread t 11)) (/= (car gr) 3))





    (cond ((equal gr '(2 43)) (setq altxt (+ altxt 0.5)))
          ((equal gr '(2 45)) (setq altxt (- altxt 0.5)))
          ((equal (car gr) 5)
           (setq ptinpl (vlax-curve-getclosestpointto enti (trans (cadr gr) 1 0)))
           (setq len (vlax-curve-getdistatpoint enti ptinpl))
           (setq tang (vlax-curve-getfirstderiv enti (vlax-curve-getparamatdist enti len)))
           (setq angu (atan (cadr tang) (car tang)))
          

           (setq text (rtos (+ inic len) 2 0)) ;                                              Cantidad de decimales
;;;           (setq text (imper (+ inic len))); imperial,Para Colocar formato 0+000
           (setq ptins (vlax-3d-point ptinpl))
           (if mtext
             (progn (vla-put-textstring mtext text) (vla-put-insertionpoint mtext ptins))
             (setq
               mtext (vla-addmtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) ptins 3 text)
             )
           )
           (vla-put-height mtext altxt)
           (vla-put-rotation mtext (+ angu (/ pi 2)))
           (vla-put-layer mtext "CADENAMIENTO")
           (vla-put-attachmentpoint mtext acattachmentpointbottomleft)
          )
    )
  )
  
  (vl-cmdf "_move" (entlast) "" ptinpl (polar ptinpl (+ angu (/ pi 1.75)) altxt))
  (vl-cmdf "_explode" (entlast) "")
  (vl-cmdf "_line" ptinpl (polar ptinpl (+ angu (/ pi 2)) (* altxt (strlen text))) "")
  (setvar 'clayer lay)
  (prin1)
)
;;;ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
(textpage);Para ver en Cuadro de Texto
(princ "\n:: Comando: \"CETR\" para Ejecutar")
(princ)
No que no logro es aplicar la Referencia a Objeto y seguir en forma continua sin salir del lisp.
Un saludo
Luis

Luis Alberto Benitez

Mensajes : 112
Fecha de inscripción : 29/03/2016

Volver arriba Ir abajo

Perpendiculares a un eje - Página 2 Empty Re: Perpendiculares a un eje

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Página 2 de 2. Precedente  1, 2

Volver arriba

- Temas similares

 
Permisos de este foro:
No puedes responder a temas en este foro.