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

Ayuda para modificar una rutina

4 participantes

Ir abajo

Ayuda para modificar una rutina Empty Ayuda para modificar una rutina

Mensaje por José Francisco Miér Mayo 03, 2017 7:27 pm

Buenos días a todos.

Pasa lo siguiente: Tengo un lisp (rutina) que da como resultado un cuadro con el acimut y la distancia entre cada vértice de una polilínea en 2d, además coloca un circulo y númera cada vértice. Esta numeración la hace respetando el como se haya creado el polígono, por lo general siempre creo el polígono con BPoly, por lo que queda en sentido anti-horario.

Pues bien, quiero modificar el lisp para asignarle al polígono un punto inicial y que además quede en sentido horario. Para esto encontré por ahí una rutina que hace eso, se llama "reorderpoly". Agregué "reorderpoly" a la rutina y al parecer trabaja, pero..............

Es por ello que les solicito ayuda. Con este "nuevo" lisp tengo que seleccionar el polígono 2 veces. Si tienen un ratito y corren la rutina lo van a entender.

Mi pregunta es: ¿Cómo o qué modifico para que solo se seleccione el polígono una vez?

Les agradezco desde ya la ayuda que puedan brindarme.

Esta es la rutina, corre al digitar TDL
;******************************************************************************************
;;; T Willey
;;; Re Order Polyline Origin
;;; http://www.theswamp.org/index.php?topic=12624.msg154976#msg154976
(defun ReOrderPoly (/ Sel Pt Pobj EntData Ptype PtList VertexPt PtListIndex StWd EndWd PolyList OldIndex StPos cnt
tmpList ShouldClose)

(vl-load-com)
(defun ChangeOldStyle (Ent Pt / Pent cnt EntData PolyInfoList StPos StPt ShouldClose)

(setq Pent Ent)
(setq cnt 0)
(while
(and
(setq Ent (entnext Ent))
(setq EntData (entget Ent))
(= (cdr (assoc 0 EntData)) "VERTEX")
)
(setq PolyInfoList
(cons
(list
cnt
(cdr (assoc 10 EntData))
(cdr (assoc 42 EntData))
(cdr (assoc 40 EntData))
(cdr (assoc 41 EntData))
)
PolyInfoList
)
)
(if (equal cnt 0)
(setq StPt (cdr (assoc 10 EntData)))
)
(setq cnt (1+ cnt))
(setq ShouldClose (equal StPt (cdr (assoc 10 EntData)) 0.0001))
)
(foreach Lst PolyInfoList
(if (equal Pt (cadr Lst))
(setq OldIndex (car Lst))
)
)
;(setq PolyInfoList (reverse PolyInfoList))
(setq StPos (vl-position (assoc OldIndex PolyInfoList) PolyInfoList))
(setq cnt StPos)
(setq Ent Pent)
(while
(and
(setq Ent (entnext Ent))
(setq EntData (entget Ent))
(= (cdr (assoc 0 EntData)) "VERTEX")
)
(setq EntData (subst (cons 10 (cadr (nth cnt PolyInfoList))) (assoc 10 EntData) EntData))
(setq EntData (subst (cons 42 (caddr (nth cnt PolyInfoList))) (assoc 42 EntData) EntData))
(setq EntData (subst (cons 40 (cadddr (nth cnt PolyInfoList))) (assoc 40 EntData) EntData))
(setq EntData (subst (cons 41 (last (nth cnt PolyInfoList))) (assoc 41 EntData) EntData))
(entmod EntData)
(setq cnt (1+ cnt))
(if (> cnt (1- (length PolyInfoList)))
(setq cnt 0)
)
)
(if ShouldClose
(progn
(setq EntData (entget Pent))
(entmod (subst '(70 . 1) (assoc 70 EntData) EntData))
)
)
(entupd Pent)
)
;-----------------------------------------------------------
(if
(and
(setq Sel (entsel "\n Select polyline: "))
(setq Pt (getpoint "\n Select new starting point: "))
(setq Pobj (vlax-ename->vla-object (car Sel)))
(setq EntData (entget (car Sel)))
(wcmatch (setq Ptype (cdr (assoc 0 EntData))) "*POLYLINE")
)
(if (= Ptype "POLYLINE")
(ChangeOldStyle (car Sel) Pt)
(progn
(setq PtList (vlax-get Pobj 'Coordinates))
(if
(and
(= (vla-get-Closed Pobj) :vlax-false)
(equal (car PtList) (nth (- (length PtList) 2) PtList) 0.0001)
(equal (cadr PtList) (last PtList) 0.0001)
)
(setq ShouldClose T)
)
(setq VertexPt 0)
(setq PtListIndex 0)
(repeat (/ (length PtList) 2)
(vla-GetWidth Pobj VerTexPt 'StWd 'EndWd)
(setq PolyList
(cons
(list
VertexPt
(list
(nth PtListIndex PtList)
(nth (1+ PtListIndex) PtList)
)
(vla-GetBulge Pobj VertexPt)
StWd
EndWd
)
PolyList
)
)
(setq VertexPt (1+ VertexPt))
(setq PtListIndex (+ 2 PtListIndex))
)
(foreach Lst PolyList
(if (equal (list (car Pt) (cadr Pt)) (cadr Lst))
(setq OldIndex (car Lst))
)
)
(setq VertexPt 0)
(setq PtList nil)
;(setq PolyList (reverse PolyList))
(setq StPos (vl-position (assoc OldIndex PolyList) PolyList))
(setq cnt StPos)
(repeat (length PolyList)
(setq tmpList (nth cnt PolyList))
(setq PtList (append PtList (cadr tmpList)))
(vla-SetBulge Pobj VertexPt (caddr tmpList))
(vla-SetWidth Pobj VertexPt (cadddr tmpList) (last tmpList))
(setq VertexPt (1+ VertexPt))
(setq cnt (1+ cnt))
(if (> cnt (1- (length PolyList)))
(setq cnt 0)
)
)
(vlax-put Pobj 'Coordinates PtList)
(if ShouldClose
(vla-put-Closed Pobj :vlax-true)
)
)
)
)
)



;********************************************************************
(DEFUN massoc (key EntData / x nlist)
(FOREACH x EntData
(IF (EQ key (CAR x))
(SETQ nlist (CONS (CDR x) nlist))
) ;_ end of if
) ;_ end of foreach
(REVERSE nlist)
)

;********************************************************************
(DEFUN c:TDL (/ ent vertices-lista poly poly-data nv aa pp hn rotu
vv vi cont conj aa pp ent
MSC MSC1 MSC2 HT FSC2 FSC3 FSC4
XD tp PO cont cont1 X Y X1
Y1 P1 P2 ang-rad ang-dec dist
punto control control1 w ww
)
(graphscr)
(setvar "cmdecho" 0)
(setvar "dimzin" 1)
(setq osm (getvar "osmode"))
(setvar "osmode" 9)
(setq angbase (getvar "angbase"))
(setvar "angbase" (* pi 0.5))
(setq angdir (getvar "angdir"))
(setvar "angdir" 1)
(setvar "orthomode" 0)
(setvar "clayer" "0") ;capa cero
(command "color" "bylayer")
;*********************************************************************
(command "layer" "N" "Lindero" "c" "5" "Lindero" "")
(ReOrderPoly)
(command "OSNAP" "OFF" "")
(setq poly (car (entsel "\nSeleccione la Polilinea 2D: ")))
(command "area" "o" poly)
(setq aa (getvar "area"))
(setq pp (getvar "perimeter"))
(setq poly-data (entget poly))
(setq vertices-lista (massoc 10 poly-data))
;**********************************************************************
(setq nv (length vertices-lista))
(setq control (length vertices-lista))
(setq control (- control 1))
;**********************************************************************
(if (= esc nil)
(setq esc 1000)
)
(setq hn (rtos esc 2 0))
(setq rotu (strcat "Escala 1:" hn " "))
(setq hn (getreal rotu))
(if (/= hn nil)
(setq ESC hn)
)
;**********************************************************************
(setq MSC (/ 1000 ESC))
(setq MSC1 (/ ESC 1000))
(setq MSC2 (/ 1000 ESC))
(setq HT (/ 2.0 MSC))
(setq FSC2 (* 20.0 MSC1))
(setq FSC3 (* 50.0 MSC1))
(setq FSC4 (* 70.0 MSC1))
(setq XD (* (/ ESC 1000) 1.5))
(setq tp (/ 1.0 MSC2))
;-----------------------------------------------------
(setq w 65)
;-----------------------------------------------------
(setq vi 1)
(setq vv vi)
(setq stx 0) (setq sty 0)
(terpri)
(setq PO (getpoint "Donde quiere la Tabla: "))
(setq CX1 (NTH 0 PO))
(setq CY1 (NTH 1 PO))
(setq CYT1 (- CY1 (* 13.5 MSC1)))
;**********************************************************************
(command "chprop" poly "" "LA" "Lindero" "")
(command "_layer" "m" "vertice" "C" "1" "" "")
(foreach vertice vertices-lista
(command "_circle" vertice tp)
)
(command "layer" "m" "Identificador" "c" "3" "" "")
(foreach vertice vertices-lista
; (command "text" "j" "r" vertice ht "90" (rtos vv 2 0))

(command "text" "j" "r" vertice ht "90" (chr w))

(setq vv (+ vv 1))
;-----------------------------------
(setq w (+ w 1))
;-----------------------------------
)
;**********************************************************************
(setvar "clayer" "0") ;capa cero
(command "color" "bylayer")
(setq cont 0)
(setq cont1 1)
;*************************************************
(setq w 65)
(setq ww 66)
;*************************************************
(setq vert 1)
(setq ver1 2)
(setq ver2 2)
(setq CXLINEA (+ CX1 (* 10.0 MSC1)))
(setq CXACIMUT (+ CX1 (* 43.0 MSC1)))
(setq CXDISTANCIA (+ CX1 (* 65.0 MSC1)))
;**********************************************************************
(REPEAT (length vertices-lista)
(setq X (CAR (NTH cont vertices-lista))) ;coordenada X
(setq Y (CADR (NTH cont vertices-lista))) ;coordenada Y
(setq stx (+ stx X))
(setq sty (+ sty Y))

(if (> cont1 control)
(setq cont1 0)
)
(setq X1 (CAR (NTH cont1 vertices-lista))) ;coordenada X
(setq Y1 (CADR (NTH cont1 vertices-lista))) ;coordenada Y

(setq PTO1 (list X Y))
(setq PTO2 (list X1 Y1))
(setq ang-rad (angle PTO1 PTO2))
(setq ang-rad (- (/ pi 2.0) ang-rad))
;**********************************************************************
(setq ang-dec (* (/ 180 pi) ang-rad))
(if (< ang-dec 0)
(setq ang-dec (+ 360 ang-dec))
)
;**********************************************************************
(setq deg (fix ang-dec))
(setq deg2 (rtos deg 2 0))
(if (= (strlen deg2) 1)
(setq degstr (strcat "0" deg2 (chr 186)))
(setq degstr (strcat deg2 (chr 186)))
)

(setq rem1 (- ang-dec deg))
(setq min1 (* rem1 60))
(setq min2 (fix min1))
(setq min3 (rtos min2 2 0))
(if (= (strlen min3) 1)
(setq minstr (strcat "0" min3 (chr 39)))
(setq minstr (strcat min3 (chr 39)))
)

(setq sec (- min1 min2))
(setq sec2 (rtos (* 60 sec) 2 0))
;**********************************************************************
;-------------------------INICIA CONDICIÓN SI SEC2 = "60"
(if (= sec2 "60")
(progn
(setq sec2 "00")
(setq min22(+ min2 1))
(setq min3 (rtos min22 2 0))
(if (= (strlen min3) 1)
(setq minstr (strcat "0" min3 (chr 39)))
(setq minstr (strcat min3 (chr 39)))
)
)
)
;-------------------------TERMINA CONDICIÓN SI SEC2 = "60"
(if (= (strlen sec2) 1)
(setq secstr (strcat "0" sec2 (chr 34)))
(setq secstr (strcat sec2 (chr 34)))
)
(if (= min3 "60")
(progn
(setq minstr (strcat "00" (chr 39)))
;(setq min3 "00")
(setq deg22(+ deg 1))
(setq deg2 (rtos deg22 2 0))
(if (= (strlen deg2) 1)
(setq degstr (strcat "0" deg2 (chr 186)))
(setq degstr (strcat deg2 (chr 186)))
)
)
)
;----------------------

(setq ang-final (strcat degstr minstr secstr))
;**********************************************************************
(setq azimuth (strcat (vl-string-subst (chr 176) "d" (angtos (- (* pi 0.5) ang-rad) 1 3))))

(setq dist (distance PTO1 PTO2))
(setq CP (LIST CXLINEA CYT1))
(setq CE (LIST CXACIMUT CYT1))
(setq CN (LIST CXDISTANCIA CYT1))
(if (> ver1 (+ control 1))
(setq ver1 1)
)

(if (> ver2 (+ control 1))
(setq ww 65)
)

(setq lineatx (strcat (chr w) " - " (chr ww)))

(setq linea (strcat (rtos vert 2 0) " - " (rtos ver1 2 0)))

(command "text" "j" "r" CN ht "90" (rtos dist 2 2))
; (command "text" "j" "r" CE ht "90" azimuth)
; (command "text" "j" "c" CP ht "90" linea)

(command "text" "j" "c" CP ht "90" lineatx)

; (command "text" "j" "r" CE ht "90" (rtos ang-dec 2 4))
(command "text" "j" "r" CE ht "90" ang-final)

(setq cont (1+ cont))
(setq cont1 (1+ cont1))
(setq CYT1 (- CYT1 (* 5.0 MSC1)))
(setq vert (+ vert 1))
(setq ver1 (+ ver1 1))
(setq ver2 (+ ver2 1))
(setq CYAREA CYT1)

(setq w (+ 1 w))
(setq ww (+ 1 ww))
)
;**********************************************************************
(setq stx (/ stx nv)) (setq sty (/ sty nv))
(setq PA (list stx sty))
(command "text" "j" "c" PA ht "90" (strcat (rtos aa 2 2)"m2"))
(setq PTO3 (polar PO 0 FSC4))
(setq CX1 (NTH 0 PO))
(setq CY1 (NTH 1 PO))

(setq CY2 (- CY1 (* 5.0 MSC1)))
(setq PTO4 (list CX1 CY2))

(setq PTO5 (polar PTO4 0 FSC4))
(setq CY2 (- CY2 (* 5.0 MSC1)))
(setq PTO6 (list CX1 CY2))
(setq PTO7 (polar PTO6 0 FSC4))
(command "color" "5")
(command "line" PO PTO3 "")
(command "line" PTO4 PTO5 "")
(command "line" PTO6 PTO7 "")
(command "color" "bylayer")
;**********************************************************************
(REPEAT (+ 1 control)
(setq CY2 (- CY2 (* 5.0 MSC1)))
(setq PTO6 (list CX1 CY2))
(setq PTO7 (polar PTO6 0 FSC4))
(command "line" PTO6 PTO7 "")
)
;**********************************************************************
(command "color" "5")
(setq PTO8 (polar PTO4 0 FSC2))
(setq PTO9 (polar PTO4 0 FSC3))
(setq PTO10 (polar PTO6 0 FSC2))
(setq PTO11 (polar PTO6 0 FSC3))
(command "line" PO PTO6 "")
(command "line" PTO3 PTO7 "")
(command "line" PTO8 PTO10 "")
(command "line" PTO9 PTO11 "")

(setq CXT1 (+ CX1 (* 35.0 MSC1)))
(setq CYT1 (- CY1 (* 3.5 MSC1)))
(setq TITULO (LIST CXT1 CYT1))

(setq CXT1 (+ CX1 (* 10.0 MSC1)))
(setq CYT1 (- CY1 (* 8.5 MSC1)))
(setq LINEA (LIST CXT1 CYT1))

(setq CXT2 (+ CX1 (* 35.0 MSC1)))
(setq CYT2 (- CY1 (* 8.5 MSC1)))
(setq ACIMUT (LIST CXT2 CYT2))

(setq CXT3 (+ CX1 (* 60.0 MSC1)))
(setq CYT3 (- CY1 (* 8.5 MSC1)))
(setq DISTANCIA (LIST CXT3 CYT3))

(setq CA (LIST CXT2 CYAREA))
(setq Superficie (strcat "Area: " (rtos aa 2 2) "m² Perimetro: " (rtos pp 2 2) "m"))
;**********************************************************************
(command "color" "4")
(command "TEXT" "j" "c" TITULO HT "90" "* DERROTERO *")
(command "color" "3")
(command "TEXT" "j" "c" LINEA HT "90" "LINEA")
(command "TEXT" "j" "c" ACIMUT HT "90" "ACIMUT")
(command "TEXT" "j" "c" DISTANCIA HT "90" "DIST.(m)")
(command "TEXT" "J" "C" CA HT "90" Superficie)
;**********************************************************************
(setvar "clayer" "0") ;capa cero
(command "color" "bylayer")
(setvar "osmode" 45)
;**********************************************************************
) ;Fin del Defun





José Francisco

Mensajes : 46
Fecha de inscripción : 30/03/2016

Volver arriba Ir abajo

Ayuda para modificar una rutina Empty Re: Ayuda para modificar una rutina

Mensaje por Marco Jacinto Vie Mayo 05, 2017 7:28 pm

Aqui va el codigo modificado, comente las lineas en donde hice cambios.
Código:

 ;******************************************************************************************
;;; T Willey
;;; Re Order Polyline Origin
;;; http://www.theswamp.org/index.php?topic=12624.msg154976#msg154976
;;; 20170505 Marco Jacinto para AcadHispano
;;; 20170505 Se agrego un argumento para obtener la polilinea en el formato
;;; que regresa entsel
(defun ReOrderPoly (Sel /       Sel  Pt     Pobj
    EntData    Ptype  PtList     VertexPt
    PtListIndex  StWd     EndWd
    PolyList   OldIndex  StPos     cnt
    tmpList    ShouldClose
   )

  (vl-load-com)
  (defun ChangeOldStyle (Ent   Pt     /       Pent
 cnt   EntData   PolyInfoList
 StPos   StPt     ShouldClose
 )

    (setq Pent Ent)
    (setq cnt 0)
    (while
      (and
 (setq Ent (entnext Ent))
 (setq EntData (entget Ent))
 (= (cdr (assoc 0 EntData)) "VERTEX")
      )
       (setq PolyInfoList
      (cons
 (list
  cnt
  (cdr (assoc 10 EntData))
  (cdr (assoc 42 EntData))
  (cdr (assoc 40 EntData))
  (cdr (assoc 41 EntData))
 )
 PolyInfoList
      )
       )
       (if (equal cnt 0)
 (setq StPt (cdr (assoc 10 EntData)))
       )
       (setq cnt (1+ cnt))
       (setq ShouldClose (equal StPt (cdr (assoc 10 EntData)) 0.0001))
    )
    (foreach Lst PolyInfoList
      (if (equal Pt (cadr Lst))
 (setq OldIndex (car Lst))
      )
    )
 ;(setq PolyInfoList (reverse PolyInfoList))
    (setq
      StPos (vl-position (assoc OldIndex PolyInfoList) PolyInfoList)
    )
    (setq cnt StPos)
    (setq Ent Pent)
    (while
      (and
 (setq Ent (entnext Ent))
 (setq EntData (entget Ent))
 (= (cdr (assoc 0 EntData)) "VERTEX")
      )
       (setq EntData (subst (cons 10 (cadr (nth cnt PolyInfoList)))
    (assoc 10 EntData)
    EntData
     )
       )
       (setq EntData (subst (cons 42 (caddr (nth cnt PolyInfoList)))
    (assoc 42 EntData)
    EntData
     )
       )
       (setq EntData (subst (cons 40 (cadddr (nth cnt PolyInfoList)))
    (assoc 40 EntData)
    EntData
     )
       )
       (setq EntData (subst (cons 41 (last (nth cnt PolyInfoList)))
    (assoc 41 EntData)
    EntData
     )
       )
       (entmod EntData)
       (setq cnt (1+ cnt))
       (if (> cnt (1- (length PolyInfoList)))
 (setq cnt 0)
       )
    )
    (if ShouldClose
      (progn
 (setq EntData (entget Pent))
 (entmod (subst '(70 . 1) (assoc 70 EntData) EntData))
      )
    )
    (entupd Pent)
  )
 ;-----------------------------------------------------------
  (if
    (and
      ;;;20170505 Se comentó esta linea, ya que la variable sel se añadio como argumento
;;;      (setq Sel (entsel "\n Select polyline: "))
      ;;;20170505 Se tradujo el comando
      (setq Pt (getpoint "\n Selecciona el nuevo punto de inicio: "))
      (setq Pobj (vlax-ename->vla-object (car Sel)))
      (setq EntData (entget (car Sel)))
      (wcmatch (setq Ptype (cdr (assoc 0 EntData))) "*POLYLINE")
    )
     (if (= Ptype "POLYLINE")
       (ChangeOldStyle (car Sel) Pt)
       (progn
 (setq PtList (vlax-get Pobj 'Coordinates))
 (if
   (and
     (= (vla-get-Closed Pobj) :vlax-false)
     (equal (car PtList)
    (nth (- (length PtList) 2) PtList)
    0.0001
     )
     (equal (cadr PtList) (last PtList) 0.0001)
   )
    (setq ShouldClose T)
 )
 (setq VertexPt 0)
 (setq PtListIndex 0)
 (repeat (/ (length PtList) 2)
   (vla-GetWidth Pobj VerTexPt 'StWd 'EndWd)
   (setq PolyList
  (cons
    (list
      VertexPt
      (list
 (nth PtListIndex PtList)
 (nth (1+ PtListIndex) PtList)
      )
      (vla-GetBulge Pobj VertexPt)
      StWd
      EndWd
    )
    PolyList
  )
   )
   (setq VertexPt (1+ VertexPt))
   (setq PtListIndex (+ 2 PtListIndex))
 )
 (foreach Lst PolyList
   (if (equal (list (car Pt) (cadr Pt)) (cadr Lst))
     (setq OldIndex (car Lst))
   )
 )
 (setq VertexPt 0)
 (setq PtList nil)
 ;(setq PolyList (reverse PolyList))
 (setq StPos (vl-position (assoc OldIndex PolyList) PolyList))
 (setq cnt StPos)
 (repeat (length PolyList)
   (setq tmpList (nth cnt PolyList))
   (setq PtList (append PtList (cadr tmpList)))
   (vla-SetBulge Pobj VertexPt (caddr tmpList))
   (vla-SetWidth Pobj VertexPt (cadddr tmpList) (last tmpList))
   (setq VertexPt (1+ VertexPt))
   (setq cnt (1+ cnt))
   (if (> cnt (1- (length PolyList)))
     (setq cnt 0)
   )
 )
 (vlax-put Pobj 'Coordinates PtList)
 (if ShouldClose
   (vla-put-Closed Pobj :vlax-true)
 )
       )
     )
  )
)



 ;********************************************************************
(DEFUN massoc (key EntData / x nlist)
  (FOREACH x EntData
    (IF (EQ key (CAR x))
      (SETQ nlist (CONS (CDR x) nlist))
    ) ;_ end of if
  ) ;_ end of foreach
  (REVERSE nlist)
)

 ;********************************************************************
(DEFUN c:TDL (/     ent    vertices-lista poly poly-data
      nv     aa    pp   hn  rotu vv vi     cont
      conj   aa    pp   ent  MSC MSC1 MSC2   HT
      FSC2   FSC3   FSC4   XD  tp PO cont   cont1
      X     Y    X1   Y1  P1 P2 ang-rad
      ang-dec    dist   punto  control control1
      w     ww
     )
  (graphscr)
  (setvar "cmdecho" 0)
  (setvar "dimzin" 1)
  (setq osm (getvar "osmode"))
  (setvar "osmode" 9)
  (setq angbase (getvar "angbase"))
  (setvar "angbase" (* pi 0.5))
  (setq angdir (getvar "angdir"))
  (setvar "angdir" 1)
  (setvar "orthomode" 0)
  (setvar "clayer" "0") ;capa cero
  (command "color" "bylayer")
 ;*********************************************************************
  (command "layer" "N" "Lindero" "c" "5" "Lindero" "")
  
  (command "OSNAP" "OFF" "")
  (setq Sel  (entsel "\nSeleccione la Polilinea 2D: ")
 poly (car Sel)
  )
  (command "area" "o" poly)
  ;;;;20170505 Se cambio la ubicacion de la llamada a la rutina, y se añadió el argumento Sel
  (ReOrderPoly SEL)
  (setq aa (getvar "area"))
  (setq pp (getvar "perimeter"))
  (setq poly-data (entget poly))
  (setq vertices-lista (massoc 10 poly-data))
 ;**********************************************************************
  (setq nv (length vertices-lista))
  (setq control (length vertices-lista))
  (setq control (- control 1))
 ;**********************************************************************
  (if (= esc nil)
    (setq esc 1000)
  )
  (setq hn (rtos esc 2 0))
  (setq rotu (strcat "Escala 1:" hn " "))
  (setq hn (getreal rotu))
  (if (/= hn nil)
    (setq ESC hn)
  )
 ;**********************************************************************
  (setq MSC (/ 1000 ESC))
  (setq MSC1 (/ ESC 1000))
  (setq MSC2 (/ 1000 ESC))
  (setq HT (/ 2.0 MSC))
  (setq FSC2 (* 20.0 MSC1))
  (setq FSC3 (* 50.0 MSC1))
  (setq FSC4 (* 70.0 MSC1))
  (setq XD (* (/ ESC 1000) 1.5))
  (setq tp (/ 1.0 MSC2))
 ;-----------------------------------------------------
  (setq w 65)
 ;-----------------------------------------------------
  (setq vi 1)
  (setq vv vi)
  (setq stx 0)
  (setq sty 0)
  (terpri)
  (setq PO (getpoint "Donde quiere la Tabla: "))
  (setq CX1 (NTH 0 PO))
  (setq CY1 (NTH 1 PO))
  (setq CYT1 (- CY1 (* 13.5 MSC1)))
 ;**********************************************************************
  (command "chprop" poly "" "LA" "Lindero" "")
  (command "_layer" "m" "vertice" "C" "1" "" "")
  (foreach vertice vertices-lista
    (command "_circle" vertice tp)
  )
  (command "layer" "m" "Identificador" "c" "3" "" "")
  (foreach vertice vertices-lista
 ; (command "text" "j" "r" vertice ht "90" (rtos vv 2 0))

    (command "text" "j" "r" vertice ht "90" (chr w))

    (setq vv (+ vv 1))
 ;-----------------------------------
    (setq w (+ w 1))
 ;-----------------------------------
  )
 ;**********************************************************************
  (setvar "clayer" "0") ;capa cero
  (command "color" "bylayer")
  (setq cont 0)
  (setq cont1 1)
 ;*************************************************
  (setq w 65)
  (setq ww 66)
 ;*************************************************
  (setq vert 1)
  (setq ver1 2)
  (setq ver2 2)
  (setq CXLINEA (+ CX1 (* 10.0 MSC1)))
  (setq CXACIMUT (+ CX1 (* 43.0 MSC1)))
  (setq CXDISTANCIA (+ CX1 (* 65.0 MSC1)))
 ;**********************************************************************
  (REPEAT (length vertices-lista)
    (setq X (CAR (NTH cont vertices-lista))) ;coordenada X
    (setq Y (CADR (NTH cont vertices-lista))) ;coordenada Y
    (setq stx (+ stx X))
    (setq sty (+ sty Y))

    (if (> cont1 control)
      (setq cont1 0)
    )
    (setq X1 (CAR (NTH cont1 vertices-lista))) ;coordenada X
    (setq Y1 (CADR (NTH cont1 vertices-lista))) ;coordenada Y

    (setq PTO1 (list X Y))
    (setq PTO2 (list X1 Y1))
    (setq ang-rad (angle PTO1 PTO2))
    (setq ang-rad (- (/ pi 2.0) ang-rad))
 ;**********************************************************************
    (setq ang-dec (* (/ 180 pi) ang-rad))
    (if (< ang-dec 0)
      (setq ang-dec (+ 360 ang-dec))
    )
 ;**********************************************************************
    (setq deg (fix ang-dec))
    (setq deg2 (rtos deg 2 0))
    (if (= (strlen deg2) 1)
      (setq degstr (strcat "0" deg2 (chr 186)))
      (setq degstr (strcat deg2 (chr 186)))
    )

    (setq rem1 (- ang-dec deg))
    (setq min1 (* rem1 60))
    (setq min2 (fix min1))
    (setq min3 (rtos min2 2 0))
    (if (= (strlen min3) 1)
      (setq minstr (strcat "0" min3 (chr 39)))
      (setq minstr (strcat min3 (chr 39)))
    )

    (setq sec (- min1 min2))
    (setq sec2 (rtos (* 60 sec) 2 0))
 ;**********************************************************************
 ;-------------------------INICIA CONDICIÓN SI SEC2 = "60"
    (if (= sec2 "60")
      (progn
 (setq sec2 "00")
 (setq min22 (+ min2 1))
 (setq min3 (rtos min22 2 0))
 (if (= (strlen min3) 1)
  (setq minstr (strcat "0" min3 (chr 39)))
  (setq minstr (strcat min3 (chr 39)))
 )
      )
    )
 ;-------------------------TERMINA CONDICIÓN SI SEC2 = "60"
    (if (= (strlen sec2) 1)
      (setq secstr (strcat "0" sec2 (chr 34)))
      (setq secstr (strcat sec2 (chr 34)))
    )
    (if (= min3 "60")
      (progn
 (setq minstr (strcat "00" (chr 39)))
 ;(setq min3 "00")
 (setq deg22 (+ deg 1))
 (setq deg2 (rtos deg22 2 0))
 (if (= (strlen deg2) 1)
  (setq degstr (strcat "0" deg2 (chr 186)))
  (setq degstr (strcat deg2 (chr 186)))
 )
      )
    )
 ;----------------------

    (setq ang-final (strcat degstr minstr secstr))
 ;**********************************************************************
    (setq azimuth (strcat (vl-string-subst
    (chr 176)
    "d"
    (angtos (- (* pi 0.5) ang-rad) 1 3)
  )
  )
    )

    (setq dist (distance PTO1 PTO2))
    (setq CP (LIST CXLINEA CYT1))
    (setq CE (LIST CXACIMUT CYT1))
    (setq CN (LIST CXDISTANCIA CYT1))
    (if (> ver1 (+ control 1))
      (setq ver1 1)
    )

    (if (> ver2 (+ control 1))
      (setq ww 65)
    )

    (setq lineatx (strcat (chr w) " - " (chr ww)))

    (setq linea (strcat (rtos vert 2 0) " - " (rtos ver1 2 0)))

    (command "text" "j" "r" CN ht "90" (rtos dist 2 2))
 ; (command "text" "j" "r" CE ht "90" azimuth)
 ; (command "text" "j" "c" CP ht "90" linea)

    (command "text" "j" "c" CP ht "90" lineatx)

 ; (command "text" "j" "r" CE ht "90" (rtos ang-dec 2 4))
    (command "text" "j" "r" CE ht "90" ang-final)

    (setq cont (1+ cont))
    (setq cont1 (1+ cont1))
    (setq CYT1 (- CYT1 (* 5.0 MSC1)))
    (setq vert (+ vert 1))
    (setq ver1 (+ ver1 1))
    (setq ver2 (+ ver2 1))
    (setq CYAREA CYT1)

    (setq w (+ 1 w))
    (setq ww (+ 1 ww))
  )
 ;**********************************************************************
  (setq stx (/ stx nv))
  (setq sty (/ sty nv))
  (setq PA (list stx sty))
  (command "text"
   "j"
   "c"
   PA
   ht
   "90"
   (strcat (rtos aa 2 2) "m2")
  )
  (setq PTO3 (polar PO 0 FSC4))
  (setq CX1 (NTH 0 PO))
  (setq CY1 (NTH 1 PO))

  (setq CY2 (- CY1 (* 5.0 MSC1)))
  (setq PTO4 (list CX1 CY2))

  (setq PTO5 (polar PTO4 0 FSC4))
  (setq CY2 (- CY2 (* 5.0 MSC1)))
  (setq PTO6 (list CX1 CY2))
  (setq PTO7 (polar PTO6 0 FSC4))
  (command "color" "5")
  (command "line" PO PTO3 "")
  (command "line" PTO4 PTO5 "")
  (command "line" PTO6 PTO7 "")
  (command "color" "bylayer")
 ;**********************************************************************
  (REPEAT (+ 1 control)
    (setq CY2 (- CY2 (* 5.0 MSC1)))
    (setq PTO6 (list CX1 CY2))
    (setq PTO7 (polar PTO6 0 FSC4))
    (command "line" PTO6 PTO7 "")
  )
 ;**********************************************************************
  (command "color" "5")
  (setq PTO8 (polar PTO4 0 FSC2))
  (setq PTO9 (polar PTO4 0 FSC3))
  (setq PTO10 (polar PTO6 0 FSC2))
  (setq PTO11 (polar PTO6 0 FSC3))
  (command "line" PO PTO6 "")
  (command "line" PTO3 PTO7 "")
  (command "line" PTO8 PTO10 "")
  (command "line" PTO9 PTO11 "")

  (setq CXT1 (+ CX1 (* 35.0 MSC1)))
  (setq CYT1 (- CY1 (* 3.5 MSC1)))
  (setq TITULO (LIST CXT1 CYT1))

  (setq CXT1 (+ CX1 (* 10.0 MSC1)))
  (setq CYT1 (- CY1 (* 8.5 MSC1)))
  (setq LINEA (LIST CXT1 CYT1))

  (setq CXT2 (+ CX1 (* 35.0 MSC1)))
  (setq CYT2 (- CY1 (* 8.5 MSC1)))
  (setq ACIMUT (LIST CXT2 CYT2))

  (setq CXT3 (+ CX1 (* 60.0 MSC1)))
  (setq CYT3 (- CY1 (* 8.5 MSC1)))
  (setq DISTANCIA (LIST CXT3 CYT3))

  (setq CA (LIST CXT2 CYAREA))
  (setq Superficie
 (strcat "Area: "
 (rtos aa 2 2)
 "m² Perimetro: "
 (rtos pp 2 2)
 "m"
 )
  )
 ;**********************************************************************
  (command "color" "4")
  (command "TEXT" "j" "c" TITULO HT "90" "* DERROTERO *")
  (command "color" "3")
  (command "TEXT" "j" "c" LINEA HT "90" "LINEA")
  (command "TEXT" "j" "c" ACIMUT HT "90" "ACIMUT")
  (command "TEXT" "j" "c" DISTANCIA HT "90" "DIST.(m)")
  (command "TEXT" "J" "C" CA HT "90" Superficie)
 ;**********************************************************************
  (setvar "clayer" "0") ;capa cero
  (command "color" "bylayer")
  (setvar "osmode" 45)
 ;**********************************************************************
) ;Fin del Defun

Marco Jacinto

Mensajes : 91
Fecha de inscripción : 12/08/2016

Volver arriba Ir abajo

Ayuda para modificar una rutina Empty Re: Ayuda para modificar una rutina

Mensaje por José Francisco Vie Mayo 05, 2017 9:12 pm

Buen día.
Marco Jacinto, en verdad, mil gracias.

Saludos

José Francisco

Mensajes : 46
Fecha de inscripción : 30/03/2016

Volver arriba Ir abajo

Ayuda para modificar una rutina Empty Re: Ayuda para modificar una rutina

Mensaje por cyberactive Vie Jun 30, 2017 12:34 am

Esta muy buena la rutina, pero tu crees que se le pueda agregar 3 columnas en la tabla de datos, como son la columna de los vertices y las dos columnas de coordenadas en X, Y, en el poligono tenga las distancias, seria genial, muchas gracias.

cyberactive

Mensajes : 28
Fecha de inscripción : 16/05/2016

Volver arriba Ir abajo

Ayuda para modificar una rutina Empty Re: Ayuda para modificar una rutina

Mensaje por Dominguez Mar Jul 04, 2017 5:58 pm

cybor escribió:Esta muy buena la rutina, pero tu crees que se le pueda agregar 3 columnas en la tabla de datos, como son la columna de los vertices y las dos columnas de coordenadas en X, Y, en el poligono tenga las distancias, seria genial, muchas gracias.
Esta aplicacion hace lo que pides, espero que te guste.

; Cuadro levantamiento de polilinea2D con vertices, Distancias, Rumbos, Azimuths, Area; Perimetro, fichero.CSV
; Actualiza modificaciones de vertices, superficie y perimetro

https://www.dropbox.com/s/7erajfqf568d44w/DTCA.VLX?dl=0

Saludos
Dominguez
Dominguez

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

Volver arriba Ir abajo

Ayuda para modificar una rutina Empty Re: Ayuda para modificar una rutina

Mensaje por cyberactive Vie Ago 04, 2017 5:26 pm

Muchas gracias maestro, disculpe no responder antes.

cyberactive

Mensajes : 28
Fecha de inscripción : 16/05/2016

Volver arriba Ir abajo

Ayuda para modificar una rutina Empty Re: Ayuda para modificar una rutina

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Volver arriba

- Temas similares

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