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?
"")
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)
teste
ResponderExcluirexpandlist
ResponderExcluirfalta esta função para que a rotina funcione...
desculpe... acho que esqueci dela, ai vai:
ResponderExcluir(defun expandlist (el qtd / lst)
(repeat qtd (setq lst (cons el lst))))