Mj4

Uma rotita para aqueles que explodiram uma polilinha que foi "transformada" em spline e explodiu a coitada:
(defun c:mj4 (/ ss ent lpt dd mj4_procpt new zc s flag lay n)
  (
tbn:error-init  (list (list "cmdecho" 0 "osmode" 0)
                         '(command "._zoom" "c" zc s)))
;seleciona as linhas:
  (setq ss     (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE")))
;pede as distancia mínimas entre pontos
;que poderão ser conciderados iguais:

        mj4:dd (if mj4:dd mj4:dd 0.001) ;lembre da próxima vez
        dd     (getdist (strcat
                          "\nQual a distância será permitida? <"
                          (rtos mj4:dd 2)
                          ">"))
        dd     (if dd dd mj4:dd)
        mj4:dd dd ;lembre na próxima utilização o valor
;função que calculará a lista de pontos da nova 3dpoly

        mj4_procpt (lambda (pt start / s2 e2 lst)
;procura as ents que podem servir:
                 (setq s2 (ssget "CP" (get-lpt 20 dd (trans pt 0 1))
                                 '((0 . "LINE,POLYLINE,LWPOLYLINE"))))
;calcula as distâncias entre PT e o inicio e o fim de cada uma delas:
                 (repeat (if s2 (sslength s2) 0)
                   (
setq e2  (ssname s2 0)
;só processa se fizer parte da seleção inicial:
;lst estará nesta forma: (distancia entidade inicio/fim)

                         lst (if (ssmemb e2 ss)
                               (
append lst
                                 (list
                                   (list
                                     (distance pt
                                       (vlax-curve-getstartpoint e2))
                                          e2 t)
                                   (
list
                                     (distance pt
                                       (vlax-curve-getendpoint e2))
                                     e2 nil)))
                               lst))
                   (
ssdel e2 s2))
;escolhe a que estiver mais perto
;colocando as distâncias em ordem crescente:

                 (setq lst (car (vl-sort lst
                                         '(lambda (e1 e2)
                                            (
< (car e1) (car e2))))))
;se der certo,
                 (if lst
;se a distancia for aceitável:
                   (if (<= (car lst) dd)
                     (
progn
; pega suas coordenadas e apague ela:
                       (setq e2 (cadr lst) ;<---------correção: 10.11.2006
                             lpt
                              (if start
                                (append
                                  (if (caddr lst)
                                    (
reverse (get-points-polig e2))
                                    (
get-points-polig e2))
                                  (
cdr lpt))
                                (
append
                                  lpt
                                  (cdr (if (caddr lst)
                                         (
get-points-polig e2)
                                         (
reverse
                                           (get-points-polig e2)))))))
                       (
ssdel e2 ss)
                       (
entdel e2)
                       t))))
        zc (getvar "viewctr")
        s  (getvar "viewsize"))
;zoom extens para o ssget não dar problema:
  (command "._zoom" "e")
;processa a seleção toda:
  (while (> (sslength ss) 0)
;pega a entidade da seleção, pega o layer e seus vertices:
    (setq ent  (ssname ss 0)
          lpt  (get-points-polig ent)
          lay  (dxf 8 ent)
          n    0
          flag nil) ;inicializa a variavel flag
;apaga a entidade:

    (entdel ent)
;enquanto conectar alguma coisa nessa lista:
    (while (or (mj4_procpt (car lpt) t) ;no inicio
               (mj4_procpt (last lpt) nil)) ;ou no fim
      (grtext -2 (strcat (itoa (sslength ss)) ": "
                         (itoa (setq n (1+ n)))))
      (
setq flag t)) ;conectou pelo menos algo?
    (if flag ;mesmo?
      (progn
;desenha uma nova polilinha:
        (setq new (draw-pline2 lpt lay nil))
        (
ssadd (handent new) ss))
;não deu... "desdeleta" a entidade:
      (entdel ent))
    (
grtext -2 (itoa (sslength ss)))
    (
ssdel ent ss))
  (
command "._zoom" "c" zc s)
  (
tbn:error-restore))



Com esta rotina será possível juntar todos os segmentos de linhas, mesmo que elas estejam em 3d, em uma entidade só. É possível até escolher uma distância cujo valor será usado para determinar a proximidade das linhas, isto é, se a distancia entre os pontos de duas linhas forem menor que este valor, as duas linhas serão soldadas neste ponto...
claro que você pode definir este valor em zero, se preferir, mas as linhas não serão emendadas se os pontos não forem exatamente iguais...
Link(s) da(s) subrotina(s) usada(s):
tbn:error-init, get-lpt, get-points-polig, dxf, draw-pline2, tbn:error-restore

4 comentários:

  1. Este comentário foi removido por um administrador do blog.

    ResponderExcluir
  2. nao, nem todos

    os que dão endereços externos ao post sim, exemplo: DXF
    esta é uma subrotina... deve ser sala e carregada a parte

    já mj4_procpt é um link para a propria pagina, percebe que a pagina apenas dá um "salto" ate ela?

    ResponderExcluir
  3. Neyton, bom dia!

    Primeiramente, me desculpe por te chamar de NeIton no post anterior e segundamente, eu sou lerdo demais!!

    Por favor, veja se o que estou fazendo está mais ou menos correto,
    Veja a montagem da sua rotina como ficou e me diga o que estou fazendo de errado.
    Eu fiz o seguinte, onde tem link para uma rotina externa, eu colei esta rotina no final da rotina mãe, veja:

    (defun c:mj4 (/ ss ent lpt dd mj4_procpt new zc s flag lay n)
    (tbn:error-init (list (list "cmdecho" 0 "osmode" 0)
    '(command "._zoom" "c" zc s)))
    ;seleciona as linhas:
    (setq ss (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE")))
    ;pede as distancia mínimas entre pontos
    ;que poderão ser conciderados iguais:
    mj4:dd (if mj4:dd mj4:dd 0.001) ;lembre da próxima vez
    dd (getdist (strcat
    "\nQual a distância será permitida? <"
    (rtos mj4:dd 2)
    ">"))
    dd (if dd dd mj4:dd)
    mj4:dd dd ;lembre na próxima utilização o valor
    ;função que calculará a lista de pontos da nova 3dpoly
    mj4_procpt (lambda (pt start / s2 e2 lst)
    ;procura as ents que podem servir:
    (setq s2 (ssget "CP" (get-lpt 20 dd (trans pt 0 1))
    '((0 . "LINE,POLYLINE,LWPOLYLINE"))))
    ;calcula as distâncias entre PT e o inicio e o fim de cada uma delas:
    (repeat (if s2 (sslength s2) 0)
    (setq e2 (ssname s2 0)
    ;só processa se fizer parte da seleção inicial:
    ;lst estará nesta forma: (distancia entidade inicio/fim)
    lst (if (ssmemb e2 ss)
    (append lst
    (list
    (list
    (distance pt
    (vlax-curve-getstartpoint e2))
    e2 t)
    (list
    (distance pt
    (vlax-curve-getendpoint e2))
    e2 nil)))
    lst))
    (ssdel e2 s2))
    ;escolhe a que estiver mais perto
    ;colocando as distâncias em ordem crescente:
    (setq lst (car (vl-sort lst
    '(lambda (e1 e2)
    (< (car e1) (car e2))))))
    ;se der certo,
    (if lst
    ;se a distancia for aceitável:
    (if (<= (car lst) dd)
    (progn
    ; pega suas coordenadas e apague ela:
    (setq lpt
    (if start
    (append
    (if (caddr lst)
    (reverse (get-points-polig e2))
    (get-points-polig e2))
    (cdr lpt))
    (append
    lpt
    (cdr (if (caddr lst)
    (get-points-polig e2)
    (reverse
    (get-points-polig e2)))))))
    (ssdel e2 ss)
    (entdel e2)
    t))))
    zc (getvar "viewctr")
    s (getvar "viewsize"))
    ;zoom extens para o ssget não dar problema:
    (command "._zoom" "e")
    ;processa a seleção toda:
    (while (> (sslength ss) 0)
    ;pega a entidade da seleção, pega o layer e seus vertices:
    (setq ent (ssname ss 0)
    lpt (get-points-polig ent)
    lay (dxf 8 ent)
    n 0
    flag nil) ;inicializa a variavel flag
    ;apaga a entidade:
    (entdel ent)
    ;enquanto conectar alguma coisa nessa lista:
    (while (or (mj4_procpt (car lpt) t) ;no inicio
    (mj4_procpt (last lpt) nil)) ;ou no fim
    (grtext -2 (strcat (itoa (sslength ss)) ": "
    (itoa (setq n (1+ n)))))
    (setq flag t)) ;conectou pelo menos algo?
    (if flag ;mesmo?
    (progn
    ;desenha uma nova polilinha:
    (setq new (draw-pline2 lpt lay nil))
    (ssadd (handent new) ss))
    ;não deu... "desdeleta" a entidade:
    (entdel ent))
    (grtext -2 (itoa (sslength ss)))
    (ssdel ent ss))
    (command "._zoom" "c" zc s)
    (tbn:error-restore t))
    ;| tbn:error-subst (s):
    substitui a função *error* do cad
    tbn:error-restore (flag) :
    restaura o sistema em caso de erro
    flag: t -> terminou o programa sem erros
    nil -> erro na execução do programa
    tbn:error-init (sys):
    inicia o sistema para pegar erros
    sys: (list_a list_b)
    list_a -> variavieis do sistema com valores
    a serem restaurados
    list_b -> uma rotina a ser executada
    em caso de erro|;
    (defun tbn:error-subst (s /)
    (while (/= 0 (getvar "cmdactive")) (command ""))

    (if (/= s "Function cancelled")
    (progn
    (princ (strcat "\nError: " s))
    (command "_.UNDO" "_e")
    (princ "\nundoing ")
    (command "_.U")
    (tbn:error-restore nil))
    (tbn:error-restore t)))

    (defun tbn:error-restore (flag /)
    (while (/= 0 (getvar "cmdactive")) (command ""))
    (command "_.REDRAWALL")
    (if flag
    (command "_.UNDO" "_E"))
    (cond
    ((/= 1 (logand tbn:error_undo 1))
    (command "_.undo" "_control" "_none"))
    ((= 2 (logand tbn:error_undo 2))
    (command "_.undo" "_control" "_one")))
    (mapcar '(lambda (x) (setvar (car x) (cadr x)))
    tbn:error_sys)
    (setq *error* tbn:error_olderr)
    (eval tbn:error_exe)
    (princ))

    (defun tbn:error-init (sys / tmp ss)
    (if m:err
    (setq tbn:error_olderr m:err
    *error* tbn:error-subst)
    (setq tbn:error_olderr *error*
    *error* tbn:error-subst))
    (setq tbn:error_exe
    (cadr sys)
    sys (car sys)
    tbn:error_sys
    nil
    tbn:error_undo
    (getvar "undoctl")
    ss (ssgetfirst))
    (repeat (/ (length sys) 2)
    (setq tmp (car sys)
    tbn:error_sys (cons (list tmp (getvar tmp))
    tbn:error_sys)
    tmp (setvar tmp (cadr sys))
    sys (cddr sys)))
    (cond
    ((= 2 (logand tbn:error_undo 2))
    (command "_.undo" "_control" "_all"
    "_.undo" "_auto" "_off"))
    ((/= 1 (logand tbn:error_undo 1))
    (command "_.undo" "_all" "_.undo"
    "_auto" "_off")))
    (command "_.UNDO" "_group")
    (sssetfirst (car ss) (cadr ss)))
    (defun get-points-polig (ent / x tp tmp)
    (setq ent (ename-of ent)
    tp (dxf 0 ent))
    (cond ((wcmatch tp "LINE,LWPOLYLINE,SPLINE,MLINE")
    (vl-remove nil
    (mapcar '(lambda (x)
    (if (member (car x) '(10 11))
    (cdr x)))
    (entget ent))))
    ((= "POLYLINE" tp)
    (while (/= "SEQEND" (dxf 0 (setq ent (entnext ent))))
    (setq tmp (append tmp (list (dxf 10 ent))))))
    ((= "VIEWPORT")
    (if (dxf 0 (dxf 340 ent))
    (get-points-polig (dxf 340 ent))
    (list (car (setq tmp (get-bounding-box ent)))
    (list (caadr tmp) (cadar tmp))
    (cadr tmp)
    (list (caar tmp) (cadadr tmp)))))))
    (defun dxf (dx ent / tmp ls? l e n)
    (if (= 'PICKSET (type ent))
    (progn
    (setq n 0)
    (repeat (sslength ent)
    (setq e (ssname ent n)
    n (1+ n)
    l (append l (list (dxf dx e)))))
    l)
    (progn
    (setq ent (if (listp ent)
    ent
    (if (setq tmp (ename-of ent))
    (entget tmp '("*"))))
    ls? (listp dx)
    dx (if ls? dx (list dx))
    tmp (if ent
    (mapcar
    '(lambda (x) (cdr (assoc x ent)))
    dx)))
    (if ls? tmp (car tmp)))))
    (defun ename-of (ent)
    (if (setq ent
    (cond
    ((= 'STR (type ent)) (handent ent))
    ((= 'VLA-OBJECT (type ent))
    (vlax-vla-object->ename ent))
    ((listp ent) (cdr (assoc -1 ent)))
    (t ent)))
    (if (entget ent) ent)))
    (defun draw-pline2 (pts lay close? / elev)
    (setq elev (caddar pts))
    (dxf 5
    (if (vl-every
    '(lambda (x) (equal x elev))
    (mapcar 'caddr pts))
    (entmakex
    (append
    (mapcar
    'cons
    '(0 100 8 100 90 70 38)
    (list "LWPOLYLINE" "AcDbEntity"
    lay "AcDbPolyline" (length pts)
    (if close? 1 0) (if elev elev 0)))
    (mapcar
    '(lambda (x) (cons 10 x))
    pts)))
    (progn
    (entmake
    (mapcar
    'cons '(0 100 8 100 70)
    (list "POLYLINE" "AcDbEntity"
    lay "AcDbPolyline"
    (if close? 9 8))))
    (foreach x pts
    (entmake
    (list '(0 . "VERTEX")
    '(100 . "AcDbEntity")
    '(100 . "AcDbVertex")
    '(100 . "AcDb3dPolylineVertex")
    (cons 10 x) '(70 . 32))))
    (entmakex '((0 . "SEQEND")
    (100 . "AcDbEntity")))
    (entlast)))))

    Sei que fiz tudo errado mas, onde está o erro para que eu possa aproveitar as rotinas postadas em seu blog.

    Abraços!!

    ** Desculpe por postar algo tão grande.

    ResponderExcluir
  4. é por ai mesmo... os links vc abre e vai colando no final (uo no inicio, eu prefiro no inicio) da rotina

    experimente carregar essa montagem que vc fez... se não der erro, ta blz...

    ResponderExcluir