Visual Lisp - Ainda não morreu!!!!

Mais um dia, mais um serviço pro estagiário....

Dessa vez, imagine o seguinte:

Você tem um eixo, que digitalizou no Google Earth, por exemplo. Ele tem, digamos 800 km

Suponha, que você tenha clicado um vértice a cada 50 metros.

Agora, imagine que em cada 1000 metros, tem um marco de quilometragem, que você digitalizou com aqueles "pinos" do Google Earth.

Agora, suponha que queira desenhar isso tudo no AutoCAD.

Obviamente, você pode usar o READKML2, para importar:

Bom, mas não satisfeito com isso, você resolve que precisa inserir no AutoCAD, um texto em cada vértice da polilinha, com o seu KM em relação aos marcos de quilometragem.

Faz as contas, 800 km, um a cada 50 m..... 16 mil textos.

Aí, claro, tem de calcular a interpolação dos pontos.

Bom, Vamos, lá programar isso, porque fazer na mão.... esquece!!!

---

;lista todos os blocos com o texto do nome da estação e km
(setq ss (ssget "X" '((0 . "INSERT") (2 . "MARCO_KM"))))

;seleciona o eixo de referencia
(SETQ EIXO (CAR (ENTSEL)))

;cria uma lista com '((distancia "codigo_estacao" km_estação) .... )
(SETQ LST
  (MAPCAR '(LAMBDA (ENT)

      ;se está no formato "CODIGO - KM", adiciona à lista
      (IF (/= "ZTO'" (GET-TAG-PROP ENT "NOME"))
        ;se o bloco está ate 30 metro do eixo, é uma estação válida, então adiciona
        (IF (< (DISTANCE (DXF 10 ENT)
    ;projeção do ponto no eixo
    (SETQ PTPROX (VLAX-CURVE-GETCLOSESTPOINTTO EIXO (DXF 10 ENT)))
    )
        30)
      

   ;cria uma lista neste formato: (distancia "codigo_estacao" km_estação)
   (APPEND
                 (LIST (VLAX-CURVE-GETDISTATPOINT EIXO PTPROX))
   (READ (STRCAT "(\"" (VL-STRING-SUBST "." ","
           (VL-STRING-SUBST "\"" " - "
      (GET-TAG-PROP ENT "NOME"))) ")"))))))
 (DXF -1 SS)))

;remove o lixo e ordena pela primeira coluna (distancia)
(SETQ LST (VL-SORT (VL-REMOVE 'NIL LST) '(LAMBDA (A B) (< (CAR A) (CAR B)))))

;lista todos os vértices do eixo, sem duplicatas
(SETQ PTS (RMPDUP (GET-POINTS-POLIG EIXO)))

;processa todos os pontos do eixo
(FOREACH PT PTS
  ;calcula a distância até o início sobre o eixo
  (SETQ DIST (VLAX-CURVE-GETDISTATPOINT EIXO PT))

  ;acha a estação posterior ao ponto em questão
  (SETQ DEPOIS (CAR (VL-REMOVE 'NIL (MAPCAR '(LAMBDA (A) (IF (> (CAR A) DIST)  A)) LST))))

  ;acha a estação anterior ao ponto em questão
  (SETQ ANTES  (LAST (VL-REMOVE 'NIL (MAPCAR '(LAMBDA (A) (IF (< (CAR A) DIST)  A)) LST))))

  ;se tem as duas, interpola
  (IF (AND ANTES DEPOIS)
    ;se são a mesma, desenha
    (IF (EQ ANTES DEPOIS)
      (DRAW-TEXT  (RTOS (CADDR ANTES) 2 0)  pt "KM" 0 5 "ARIAL" "TR"  )

      ;se a distância interpolada "D" em KM da estação anterior é menor que 2200,
      ;pois tem uma estação faltando, desenha, senão marca com círculo
      (IF (< (SETQ D ( * (- DIST (CAR ANTES))
    (/ (- (CAR DEPOIS) (CAR ANTES))
       (- (CADDR DEPOIS) (CADDR ANTES)))))
      2200)
 (DRAW-TEXT  (RTOS (+ (CADDR ANTES) D ) 2 0)  pt "KM" 0 5 "ARIAL" "TR"  )
 (ENTMAKE (LIST (CONS 0 "CIRCLE") (CONS 10 PT) (CONS 40 4) (CONS 8 "ERRO")))))

    ;se só tem a estação posterior
    (IF DEPOIS
      ;se a distância da estação posterior é menor que 2200, desenha, senão marca com círculo
      (IF (< (- (CAR DEPOIS) DIST) 2200)
         (DRAW-TEXT (RTOS (- (CADDR DEPOIS) (- (CAR DEPOIS) DIST)) 2 0)  pt "KM" 0 5 "ARIAL" "TR"  )
         (ENTMAKE (LIST (CONS 0 "CIRCLE") (CONS 10 PT) (CONS 40 4) (CONS 8 "ERRO"))))

      ;se só tem a estação anterior
      (IF ANTES
 ;se a distância da estação anterior é menor que 2200, desenha, senão marca com círculo
 (IF (< (- DIST (CAR ANTES) ) 2200)
   (DRAW-TEXT (RTOS (+ (CADDR ANTES) (- DIST (CAR ANTES) )) 2 0) pt "KM" 0 5 "ARIAL" "TR")
   (ENTMAKE (LIST (CONS 0 "CIRCLE") (CONS 10 PT) (CONS 40 4) (CONS 8 "ERRO"))))
      ))))

---

Ah, DXF, GET-TAG-PROP, RMPDUP, GET-POINTS-POLIG, DRAW-TEXT, são subrotinas que estão aqui na página. Divirta-se procurando elas!!!!

Olha o resultado:

Difícil?

O programinha tem 74 linhas, gastei uns 20 minutos para escrever, depurar e rodar.

Agora, faz as contas de quanto aquele seu estagiário precisaria para fazer o mesmo trabalho ??

Sim, me pediram mesmo pra fazer esse trabalho... hehehe

Usando vla-GetDynamicBlockProperties

Outro dia um camarada me perguntou como alterar o valor de um atributo dinâmico em um bloco. Bom escrevi um pequeno programa para exemplificar, segue:

---

;subrotina que retorna a lista de atributos dinamicos de um bloco
;vlabloc é o ponteiro VLA para o bloco
(defun get-dynamic-attributes (vlabloc)
  ;(vl-load-com)
  
  (mapcar '(lambda (p) (cons (vla-get-PropertyName p) p))
                (vlax-safearray->list
                  (vlax-variant-value
                (vla-GetDynamicBlockProperties vlabloc)))))


;exemplo de uso:
;|
carrega as funções vl
(vl-load-com)


;selecione um bloco dinamico na tela
(setq bloco (vlax-ename->vla-object (car (entsel "\nSelecione o bloco"))))

;pega a lista de atributos:
(setq atts (get-dynamic-attributes bloco))

;da lista, pegue o atributo COMPRIMENTO:
(setq attComprimento (cdr (assoc "COMPRIMENTO"  atts)))

;alerta sobre o valor atual
(alert (strcat "O valor atual é: " (rtos (vlax-variant-value (vla-get-value attComprimento)) 2 3)))

;redefine o valor para outro valor qualquer
(vla-put-value attComprimento 2.0)

;alerta para o novo valor:
(alert (strcat "O valor atual é: " (rtos (vlax-variant-value (vla-get-value attComprimento)) 2 3)))

|;

---

É simples, né? O exemplo te ensina a listar os atributos, que você poderá pegar e alterar.

Novo plugin para engenharia: MMATERIAL

Um novo plugin foi inserido no pacote TBN2C3D (plugins para Civil 3D), é o MMATERIAL. Este plugin cria Material List em todos os alinhamentos selecionados ao mesmo tempo!!!

Se você trabalha com loteamentos, já se teve a maçante tarefa de criar perfis, modelar corredores, superfícies, seções gabaritadas e listas de corte e aterro para mais de 10 alinhamentos.

Ao criar essas Material List para quantificar corte e aterro, você tem de preencher várias informações e mesmo tendo o template bem feito isso pode ser bem demorado de fazer.
Pensando nisso, o pacote TBN2C3D pode te ajudar, vejas os plugins:

1. MPERFIL, cria perfil de superfície em múltiplos alinhamentos
2. MPROFVIEW, cria profileview de múltiplos alinhamentos
3. MCORREDOR, cria corredor em múltiplos alinhamentos
4. MCORRSURF, cria superfícies de múltiplos corredores
5. MSAMPLELINE, cria sample line group de múltiplos alinhamentos
6. MMATERIAL, cria Material List de múltiplos alinhamentos

Coloquei na sequencia todos os plugins necessários para reduzir, quantas ruas tem seu loteamento? 20 ou mais?, sim, reduzir essa tarefa em pelo menos 20, ou mais, vezes!!!
Gostou? Então entre em contato para adquirir agora mesmo!!! Tem preços especiais para pacotes com mais de um plugin!!!

Loteamento Explodido? Lamentável, mas tem jeito!!!

Hoje recebi um pedido de um cliente para testar o CADMEMO no projeto dele. Só que o desenho era CAD puro e os lotes não eram polilinhas fechadas, nem ao menos os nomes dos lotes eram blocos. Condições estas para o CADMEMO funcionar.

Bem, isso é problema? Sim, de certa forma. Se fosse converter tudo em PARCEL no Civil 3D, ainda teria de renomear os parcels gerados....

A maneira mais rápida que consegui pensar pra isso é escrever um pequeno lisp para interpretar o projeto e criar as polilinhas e os blocos.

O código fonte segue abaixo. Veja que usei o comando BPOLY para obter uma polilinha fechada e inseri o bloco necessário no centroide da polilinha.

Para obter este centroide, usei uma REGION temporária.

Para rodar é bem simples, tenha os blocos:
LOTE - bloco que informará o nome do lote, tem os atributos NOME, AREA, DESC
QUADRA - bloco que informará o nome da quadra, tem o atributo NOME

Agora, carregue com o APPLOAD.

Ao chamar o comando na linha de comando, serão pedidas as informações de nome do layer, bloco etc, caso você queira reconfigurar os parâmetros do lisp.

Bom, sem mais delongas, segue o código:

---

;lembrar valores padrão:
(setq txtl2pl:blocolote "LOTE"
      txtl2pl:layernomelote "DIM"
      txtl2pl:layerlote     "LOTE"
      txtl2pl:escala        0.3
      txtl2pl:areatpl       "A={}m²"
      txtl2pl:raioerro      3
      txtl2pl:layererro    "_erro"
      txtl2pl:filtro       "L.*"
      txtl2pl:attnome      "NOME"
      txtl2pl:attarea      "AREA"
      txtl2pl:attdesc      "DESC"
      txtl2pl:desc         "c3dmemo")

;programa que desenha polilinha e bloco com atributos
(defun c:txtl2pl (/ ss ent pl bloco vla thisdrawing rg
          objArray rg Centroid att tag model tmp)
  ;controle de erros:
  (tbn:error-init nil)
  
  ;inicia ponteiros para o desenho atual e model space
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))
    model       (vla-get-modelspace thisdrawing))

  ;reconfigura os valores padrão:
  (setq tmp  (car (entsel (strcat
     "\nClique um texto para obter o layer do nome do"
     " lote ou clique enter para aceitar <"
     txtl2pl:layernomelote ">"))))

  (if tmp (setq txtl2pl:layernomelote (cdr (assoc 8 (entget tmp)))))

  (setq tmp (getstring (strcat
     "\nInforme o nome do bloco"
     " a inserir ou clique enter para aceitar <"
     txtl2pl:blocolote ">")))

  (if (/= "" tmp) (setq txtl2pl:blocolote tmp))

  (setq tmp (getstring  (strcat  "\nInforme o atributo do"
    " nome do lote, ou enter para aceitar <" txtl2pl:attnome ">")))

  (if (/= "" tmp) (setq txtl2pl:attnome tmp))

  (setq tmp (getstring (strcat  "\nInforme o atributo da"
    " area do lote, ou enter para aceitar <" txtl2pl:attarea ">")))

  (if (/= "" tmp) (setq txtl2pl:attarea tmp))

  (setq tmp (getstring (strcat "\nInforme o atributo da descrição"
    " do lote, ou enter para aceitar <" txtl2pl:attdesc ">")))

  (if (/= "" tmp) (setq txtl2pl:attdesc tmp))

  (setq tmp (getstring (strcat "\nInforme uma descrição a aplicar,"
    " ou enter para aceitar <" txtl2pl:desc ">")))

  (if (/= "" tmp) (setq txtl2pl:desc tmp))

  (setq tmp (getstring (strcat "\nInforme o layer da polilinha de"
    " lote, ou enter para aceitar <" txtl2pl:layerlote ">")))

  (if (/= "" tmp) (setq txtl2pl:layerlote tmp))

  (setq tmp (getstring (strcat "\nInforme o filtro de texto do"
   " nome do lote, ou enter para aceitar <" txtl2pl:filtro ">")))

  (if (/= "" tmp) (setq txtl2pl:filtro tmp))

 
  ;inicia a seleção dos textos a processar:
  (prompt (strcat
    "\nSelecione os textos do layer <" txtl2pl:layernomelote ">"))
  (setq ss  (ssget (list '(0 . "TEXT")
             (cons 8 txtl2pl:layernomelote)
             (cons 1 txtl2pl:filtro))))

  ;garante que exista o layer da polilinha e dos
  ;círculos de erro se ocorrerem:
  (vla-add (vla-get-layers thisdrawing) txtl2pl:layerlote)
  (vla-add (vla-get-layers thisdrawing) txtl2pl:layererro)

  ;repita em todos os textos:
  (repeat (sslength ss)

    ;pega o promeiro da lista
    (setq ent (ssname ss 0)
      pt  (cdr (assoc 10 (entget ent)))
      vla (vlax-ename->vla-object ent))

    ;remove ele da lista
    (ssdel ent ss)

    ;zoom no texto, para o bpoly funcionar corretamente
    (vla-zoomcenter (vlax-get-acad-object)
      (vlax-3d-point pt) (getvar "viewsize"))

    ;tenta o bpoly
    (if (vl-catch-all-error-p
     (setq pl (vl-catch-all-apply 'bpoly (list pt))))
      ;se falhar, marca com um círculo
      (vla-put-layer (vla-addCircle model (vlax-3d-point pt)
               txtl2pl:raioerro) txtl2pl:layererro)

      ;se funcionar, insere o bloco do nome
      ;do lote no centroide da polilinha
      (progn
    ;obtem a polilinha
    (setq pl       (vlax-ename->vla-object pl)
          objArray (vlax-make-safearray vlax-vbObject '(0 . 0)))

    ;seta o seu layer
    (vla-put-layer pl txtl2pl:layerlote)

    ;cria uma region temporaria na polilinha,
    ;para obter o centroide
    (vlax-safearray-fill objArray (list pl))
 
        (setq rg       (car (vlax-safearray->list
                  (vlax-variant-value
                (vla-addregion model objArray))))
          Centroid (vlax-safearray->list
             (vlax-variant-value (vla-get-Centroid rg)))
          Centroid (list (car Centroid) (cadr Centroid) 0.0)

          ;insere o bloco
          bloco    (vla-insertblock (vla-get-modelspace thisdrawing)
             (vlax-3d-point Centroid)
             txtl2pl:blocolote txtl2pl:escala
             txtl2pl:escala
             txtl2pl:escala (vla-get-rotation vla)))

    (vla-put-layer bloco txtl2pl:layerlote)

    ;apaga a region
    (vla-delete rg)

    ;preenche os atributos do bloco
    (foreach att (vlax-safearray->list
               (vlax-variant-value
             (vla-GetAttributes bloco)))
      (setq tag (vla-get-tagstring att))
      (cond ((eq (strcase tag) (strcase txtl2pl:attnome))
         (vla-put-textstring att (vla-get-textstring vla)))
        ((eq (strcase tag) (strcase txtl2pl:attdesc))
         (vla-put-textstring att txtl2pl:desc))
        ((eq (strcase tag) (strcase txtl2pl:attarea))
         (vla-put-textstring att
           (vl-string-subst
             (rtos (vla-get-area pl) 2 2)
             "{}" txtl2pl:areatpl )))))))
    )

  (tbn:error-restore)
  )


(defun tbn:error-init (sys / tmp ss cmd)
  (setq tbn:olderr     *error*
    *error*        (lambda (s)      
             (if (/= s "Function cancelled")
               (prompt "\nBomb!! Error: "))
             (eval tbn:error_exe)
             (tbn:error-restore))
    tbn:error_exe  (cadr sys)
        sys            (car sys)
    tbn:sysvars    nil 
        ss             (ssgetfirst))

  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object)))


  (repeat (/ (length sys) 2)
    (setq tmp         (car sys)
          tbn:sysvars (cons (list tmp (getvar tmp))
                tbn:sysvars)
          tmp         (setvar tmp (cadr sys))
          sys         (cddr sys)))
  (sssetfirst (car ss) (cadr ss)))


(defun tbn:error-restore (/ cmd x)
  (foreach x tbn:sysvars (setvar (car x) (cadr x)))
  (redraw)
  (setq *error* tbn:olderr)
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object)))
  (princ))

---

Veja o dwg de exemplo