Rtc3 -> Reactors

Esta rotina desenha um bloco contendo as coordenadas X, Y e Z e o Nome de um ponto clicado. Este bloco aponta uma polilinha para esta posição e ambas as estidades respondem a comandos de edição com Reactors, conferindo uma certa inteligência a este bloco...
Experimente usar o Stretch, Move, Attedit... e verás...

as subrotinas que aparecem sublinhadas mas que ainda não foram postadas o serão assim que possível!!!
(defun c:rtc3  (/ pt p tag lay tmp os xd prf esc cota
                nome pnome vars lst rea escval
)
  (
tbn:error-init (list (list "cmdecho" 0) T))
  (
setq vars '("escval" "lay" "prf" "cota" "pnome"))
  (
mapcar
    '(lambda (k v / tmp)
       (
set (read k)
         (
if (setq tmp (getcfg
                (strcat "Appdata/rtc2_param/" k)))
              (
if (/= "" tmp) tmp v) v)))
    vars
    (list "1" (getvar "clayer") "X" "N" "S"))
  (
setq esc (atof escval))
  (
while (progn
           (initget
             (strcat "N E L P C"
                     (if (> (length lst) 0) " U" ""))
                    0)
           (
setq pt
            (getpoint
              (strcat "\nNomes: " pnome ", Escala: "
                      escval ", Layer: " lay ", Prefixo: "
                      prf ", Cotas: "  cota
"\nEntre com o ponto [Nome, Escala, Layer, Prefixos, Cota"
                      (if (> (length lst) 0) ", Undo" "")
                      "] "))))
    (
cond
      ((= "E" pt)
       (
setq tmp    (getreal
                      (strcat "\nQual a altura do texto? <"
                              escval ">"))
             esc    (if tmp tmp esc)
             escval (rtos esc)))
      ((
= "L" pt)
       (
setq tmp (getstring
                   (strcat "\nQual o layer? <" lay ">") t)
             lay (if tmp
                   (if (and (/= "" tmp)
                            (
validate-layname tmp))
                     tmp lay)
                   lay)))
      ((
= "P" pt)
       (
initget "X N" 0)
       (
setq tmp (getkword
                   (strcat "\nQuais prefixos? [Xyz, Neh] <"
                           prf ">"))
             prf (if tmp tmp prf)))
      ((
= "N" pt)
       (
initget "S N" 0)
       (
setq tmp (getkword
                   (strcat "\nPontos com Nome? [Sim, Não] <"
                           pnome ">"))
             pnome (if tmp tmp pnome)))
      ((
= "C" pt)
       (
initget "S N" 0)
       (
setq tmp  (getkword
                    (strcat "\nColocar Cota? [Sim, Não] <"
                            cota ">"))
             cota (if tmp tmp z)))
      ((
= "U" pt)
       (
setq tmp (car lst) lst (cdr lst))
       (
vlr-remove (caddr tmp))
       (
del-ent (car tmp))
       (
del-ent (cadr tmp)))
      (
t
       (setq nome (if (= pnome "S")
                    (
getstring
                      "\nQual o nome do ponto? " t)
                    "")
             pt   (trans pt 1 0)
             p    (draw-pline2 (expandlist pt 4) lay nil)
             tag  (rtc3:draw-tag)
             os   (getvar "osmode"))
       (
command "osmode" 0 "cmdecho" 1
                "move" (handent tag) "" (trans pt 0 1))
       (
setvar "osmode" os)
       (
while (wcmatch (getvar "cmdnames") "*MOVE*")
         (
command pause))
       (
setq p2 (getvar "lastpoint"))
       (
setvar "cmdecho" 0)
       (
command "osmode" 0 "cmdecho" 1
                "rotate" (handent tag) "" p2)
       (
setvar "osmode" os)
       (
while (wcmatch (getvar "cmdnames") "*ROTATE*")
         (
command pause))
       (
setvar "cmdecho" 0)
       (
setq xd (list (cons 1005 p)
                      (
cons 1005 tag)
                      (
cons 1000 prf)
                      (
cons 1000 cota)
                      (
cons 1042 esc)))
       (
put-xdata2 tag xd "RTC3_ENTS")
       (
put-xdata2 p xd "RTC3_ENTS")
       (
setq rea
          (vlr-object-reactor
            (list (vlax-ename->vla-object (handent p))
                  (
vlax-ename->vla-object (handent tag)))
            (
list p tag)
            '((:vlr-subObjModified . rtc3:update)
              (
:vlr-modified . rtc3:update)))
             lst (cons (list p tag rea) lst))
       (
command "move" (handent tag) "" '(0 0) '(0 0)))))
  (
mapcar '(lambda (k)
             (
setcfg (strcat "Appdata/rtc2_param/" k)
                     (
eval (read k))))
          vars)
  (
tbn:error-restore t))

(
defun rtc3:draw-tag  nil
  (if (not (tblsearch "block" "rtc3_tags"))
    (
progn
      (entmake '((0 . "BLOCK")
                 (
2 . "rtc3_tags")
                 (
8 . "0")
                 (
10 0.0 0.0 0.0)
                 (
70 . 2)))
      (
draw-attribute t t 0 "NOME" "" '(0.5 1.6)
        "0" 0 1 "arial" "l")
      (
draw-attribute t t 0 "X" "" '(0.5 0.3)
        "0" 0 1 "arial" "l")
      (
draw-attribute t t 0 "Y" "" '(0.5 -0.3)
        "0" 0 1 "arial" "tl")
      (
draw-attribute t t 0 "Z" "" '(0.5 -1.6)
        "0" 0 1 "arial" "tl")
      (
entmake '((0 . "ENDBLK")))))
  (
draw-insert "rtc3_tags" pt lay 0  esc
    (list '("NOME" "X" "Y" "Z")
          (
cons nome (rtc3:formatacoordenada)))))

(
defun rtc3:formatacoordenada  nil
  (list (strcat (if (= prf "X") "X" "E")
                "=" (fnum (car pt) 3))
        (
strcat (if (= prf "X") "Y" "N")
                "=" (fnum (cadr pt) 3))
        (
if (= cota "S")
          (
strcat (if (= prf "X") "Z" "H")
                  "=" (fnum (caddr pt) 3)) "")))

(
defun rtc3:update  (ent rea par /)
  (
if (apply 'or
        (mapcar '(lambda (x)
                   (
wcmatch (getvar "cmdnames") x))
                '("*MOVE*" "*ROTATE*" "*GRIP_STRETCH*"
                  "*SCALE*" "*MIRROR*" "*TRIM*"
                  "*EXTEND*" "*ERASE*" "*ATTEDIT*"
)))
    (
if (vlax-erased-p ent)
      (
vlr-editor-reactor rea
        '((:vlr-commandEnded . rtc3:erase)))
      (
vlr-editor-reactor
        (list ent rea)
        '((:vlr-commandEnded . rtc3:doupdate))))))

(
defun rtc3:erase  (rea com / tmp)
  (
vlr-remove rea)
  (
mapcar 'del-ent (vlr-data (vlr-data rea))))

(
defun rtc3:getvalue  (n / tmp pos)
  (
setq tmp (get-tag-prop tag n)
        pos (vl-string-search "=" tmp))
  (
unformatnum (substr tmp (if pos (+ pos 2) 1) 10000)))

(
defun rtc3:doupdate (rea com / tmp ent oldr p tag
                      prf cota esc rot nome f xd dy
)
  (
setq tmp  (vlr-data rea)
        ent  (car tmp)
        oldr (cadr tmp)
        nome "")
  (
vlr-remove rea)
  (
if ent
    (progn 
      (mapcar 'set '(p tag prf cota esc)
              (
get-xdata2 ent "RTC3_ENTS"))
      (
if (= (dxf 5 ent) p)
        (
setq pts (get-points-polig p)
              p2  (if (caddr pts) (caddr pts) (cadr pts))
              pt  (append (car pts)
                    (
if (= cota "S")
                      (
list (dxf 38 p))
                      '(0.0)))
              lay (dxf 8 p)
              p   ent
              rot
 (angle p2 (if (cadddr pts)
                              (
cadddr pts)
                              p2))
              tag (vlax-ename->vla-object
                    (handent
                      (if (ename-of tag)
                        tag
                        (rtc3:draw-tag)))))
        (
setq cota (if (= "" (get-tag-prop tag "Z"))
                     "N" "S")
              pt   (list (rtc3:getvalue "X")
                         (
rtc3:getvalue "Y")
                         (
if (= cota "S")
                           (
rtc3:getvalue "Z")
                           0.0))
              esc  (dxf 41 tag)
              rot  (dxf 50 tag)
              p2   (dxf 10 tag)
              lay  (dxf 8 tag)
              tag  ent
              prf
  (if (vl-string-search "X"
                     (strcase (get-tag-prop tag "X")))
                     "X" "E")
              p    (vlax-ename->vla-object
                     (handent
                       (if (ename-of p)
                         p
                         (draw-pline2 (list pt pt pt)
                           lay nil))))))
      (
vlr-owner-remove oldr tag)
      (
vlr-owner-remove oldr p)
      (
setq xd (list (cons 1005 (vla-get-handle p))
                     (
cons 1005 (vla-get-handle tag))
                     (
cons 1000 prf)
                     (
cons 1000 cota)
                     (
cons 1042 esc)))
      (
put-xdata2 tag xd "RTC3_ENTS")
      (
put-xdata2 p xd "RTC3_ENTS")
      (
set-dxf-tag tag 1 '("X" "Y" "Z")
        (
rtc3:formatacoordenada))
      (
setq p3 (polar p2 rot (+ esc (apply 'max
                 (mapcar
                   '(lambda (x)
                     (
apply 'distance
                       (textbox
                         (list
                           (cons -1 (get-entname-of-tag
                                      tag x))))))
                   '("NOME" "X" "Y" "Z"))))))

      (
if (< (distance pt p3) (distance pt p2))
        (
setq tmp p2 p2 p3 p3 tmp p4 p3))

      (
setq rot (angle (trans p2 0 1) (trans p3 0 1))
            f   (and (>= rot (/ pi 2))
                     (
< rot (* 3 (/ pi 2))))
            rot (angle p2 p3))

      (
vla-put-rotation  tag
        (if f (angle p3 p2) rot))
      (
vla-put-insertionpoint tag
        (vlax-3d-point (if f p3 p2)))

      (
vlax-put-property p
        "Coordinates"
        (vlax-safearray-fill
          (vlax-make-safearray vlax-vbdouble '(0 . 7))
          (
apply
            'append
            (mapcar '(lambda (x)
                       (
list (car x) (cadr x)))
                    (
list pt (polar pt (angle pt p2) esc)
                          p2 p3)))))
      (
vla-SetWidth p 0 0 (/ esc 3.0))
      (
vla-put-elevation p (caddr pt))
      (
vlr-owner-add oldr tag)
      (
vlr-owner-add oldr p)))
  (
princ))

(
defun rtc3:ativatodososreactors (/ tmp ss ent e2 xd tag p)
  (
mapcar
    '(lambda (r / tmp)
       (
setq tmp (mapcar 'cdr (vlr-reactions r)))
       (
if
         (or (member 'rtc3:doupdate tmp)
             (
member 'rtc3:update tmp))
          (
vlr-remove r)))
    (
apply 'append (mapcar 'cdr (vlr-reactors))))
  (
if (setq ss
             (ssget "X" '((0 . "INSERT,LWPOLYLINE")
                          (
-3 ("RTC3_ENTS")))))
    (
while (> (sslength ss) 0)
      (
setq ent (ssname ss 0)
            xd  (get-xdata2 ent "RTC3_ENTS")
            p   (handent (car xd))
            tag (handent (cadr xd)))
      (
if p (ssdel p ss))
      (
if tag (ssdel tag ss))
      (
if (or p tag)
        (
vlr-object-reactor
          (append
            (if (ename-of p)
              (
list (vlax-ename->vla-object p)))
            (
if (ename-of tag)
              (
list (vlax-ename->vla-object tag))))
          (
list p tag)
          '((:vlr-subObjModified . rtc3:update)
            (
:vlr-modified . rtc3:update))))))
  (
princ))

(
rtc3:ativatodososreactors)


3 comentários:

  1. expandlist

    falta esta função para que a rotina funcione...

    ResponderExcluir
  2. Anônimo5/3/07 14:17

    desculpe... acho que esqueci dela, ai vai:
    (defun expandlist (el qtd / lst)
    (repeat qtd (setq lst (cons el lst))))

    ResponderExcluir