Lisp para preencher estaqueamento no carimbo

Sabe quando você tem as sectionviews em trocentas folhas no model space? Aí vem aquele camarada e diz: Cada folha precisa ter quais estacas estão na folha!!!! E você se vê digitando manualmente cada um dos carimbos, e você tem lá seus 150 carimbos. É, demora pra caramba!! Então que tal fazer com uma lispezinha básica, veja:

---

;|
CarimboSv, programa para preencher o estaquemamento nos carimbos
autor: Neyton Luiz Dalle Molle
Engenheiro Civil
contato: neyton@yahoo.com
https://tbn2net.com
https://tbn2.blogspot.com
;licença de uso: free
;garantias: nenhuma!!! use por sua propria conta e risco!!!
|;

;variaveis globais para "lembrar" algumas opções
(setq
;nome do bloco a ser filtrado
      CarimboSv:nomeBloco  "A1"
;nome do atributo a modificar
      CarimboSv:nomeAtt    "SUBTÍTULO_2_DO_DESENHO"
;template do texto a aplicar no atributo
      CarimboSv:template   "KM {INICIO} À KM {FIM}")

(defun c:CarimboSv (/ tmp ss ent vla att alin txt pai s2 getStation)
  ;inicializar o controle de erros
  (tbn:error-init nil)

  ;perguntar na linha de comando pelos valores
  (setq tmp                 (getstring
                  (strcat "\nQual o nome do bloco da folha? <"
                      CarimboSv:nomeBloco
                      ">")
                  t)

    CarimboSv:nomeBloco (strcase
                  (if (= "" tmp)
                CarimboSv:nomeBloco tmp))

    tmp                (getstring
                 (strcat "\nQual o nome do atributo? <"
                     CarimboSv:nomeAtt
                     ">")
                 t)
    
    CarimboSv:nomeAtt  (strcase
                 (if (= "" tmp)
                   CarimboSv:nomeAtt tmp))
;subrotina para obter o "dono" ou "pai" de um objeto
    pai                (lambda (v)
                 (vlax-get-property v "parent"))
    
;subrotina para criar a estaca como string
    getStation         (lambda (estaca componente template)
                 (vl-string-subst
                   (vlax-invoke-method
                 alin
                 "GetStationStringWithEquations"
                 estaca)
                   componente
                   template)))

;pede a seleção dos blocos
;nao filtrar aqui. blocos dinamicos tendem a mudar de nome para
;*Uxxx
  (prompt "\nSelecione os blocos")
  (setq    ss (ssget   '(( 0 . "insert"))))

; repita para todos os blocos
  (repeat (sslength ss)

;pega o primeiro da lista
    (setq ent (ssname ss 0)
      vla (vlax-ename->vla-object ent))

;se tem o nome correto (blocos dinamicos mudam para *U...
    (if (= CarimboSv:nomeBloco (STRCASE (vla-get-effectivename vla)))
      (progn

;faz zoom no bloco
    (vla-getboundingbox vla 'minp 'maxp)
    (vla-zoomwindow (vlax-get-acad-object) minp maxp)

;seleciona as sectionviews dentro da folha
    (setq s2 (ssget "C" (vlax-safearray->list minp)
            (vlax-safearray->list maxp)
            ' ((0 . "AECC_GRAPH_SECTION_VIEW")))
          alin     (pai (pai (pai (vlax-ename->vla-object
                    (ssname s2 0)))))
          primeiro 1e10
          ultimo   -1e10)
    
;calcula a primeira e a ultima seção
    (repeat (sslength s2)
      (setq e   (ssname s2 0)
        tmp (vlax-get-property
              (pai (vlax-ename->vla-object e)) "station"))
      (if (< tmp primeiro) (setq primeiro tmp))
      (if (> tmp ultimo) (setq ultimo tmp))
      (ssdel e s2))

;formata a string com o template
    (setq txt (getStation primeiro "{INICIO}" CarimboSv:template)
          txt (getStation ultimo  "{FIM}" txt))

;atribui o novo texto a todos os
;atributos com o nome selecionado
    (foreach att (vlax-safearray->list
            (vlax-variant-value
              (vla-GetAttributes vla)))
      (if (= CarimboSv:nomeAtt
         (strcase (vla-get-tagstring att)))
        (vla-put-textstring att txt)))))

;retira o primeiro bloco da lista e recomeça
;o looping
    (ssdel ent ss))

;devolve o controle de erros ao autocad
  (tbn:error-restore))

(prompt
"
Preenche estacas no carimbo carregado!!
suporte: neyton@yahoo.com
visite: https://tbn2net.com
e também: https://tbn2.blogspot.com
Digite: CarimboSv para usar
")
(princ)


Link(s) da(s) subrotina(s) usada(s): tbn:error-init, tbn:error-restore

---

É isso. Você será questionado pelo nome do bloco, o nome do atributo e o template a usar. Depois será pedida a seleção dos blocos. Note que se você mudar os valores padrão que a lisp usa para os nomes e template, o programa "lembra" na próxima utilização. Se você sempre usa outros nomes, edite o início da lisp, se souber o que está fazendo Sim, você precisará copiar o código do controle de erro aqui. Sim é preciso colocar o (vl-load-com) no início.

Atributos Multilinhas - Mudando sua largura

Um lispezinho básico pra variar!!!

Use este programa para redimensionar a largura de atributos multi linhas de blocos. O que, não sabia que atributos podem ser multi linha, como MTEXT? Cara, tu tem que usar, é muito bom!!!, resolve uma penca de problemas... esse negócio de ficar criando trocentos atributos para criar várias linhas no bloco, principalmente nos carimbos é tão R14.... hehehehe

Bom, vamos lá então:

---

;|MtAttLarg
Programa para definir a largura de
atributos multilinha em blocos
Autor: Neyton Luiz Dalle Molle
email: neyton@yahoo.com
Permissão de uso: Livre,
desde que mantido os créditos
|;

;carrega as funções vla*
(vl-load-com)

;variavel global para lembrar a largura
(setq MtAttLarg:largura 35)

;variavel blobal para remoção de quebras
(setq MtAttLarg:RemoveQuebra "Sim")

;programa principal
(defun c:MtAttLarg (/ ss ent vla largura att RemoveQuebra)
;inicia o controle de erros
  (tbn:error-init nil)

;pede a seleção dos blocos
  (prompt "\nSelecione os blocos")
  (setq ss (ssget   '((0 . "insert"))))
  (if (not ss) (exit))

;pede a largura do mtext
  (setq largura (getdist
          (strcat "\nQual a largura desejada? "
              "<" (rtos MtAttLarg:largura) ">"))
    largura (if largura largura MtAttLarg:largura)
    MtAttLarg:largura largura)

;pergunta se quer remover quebras
  (initget "Sim Não" 0)
  (setq RemoveQuebra (getkword (strcat
        "\nRemover quebras de linha? [Sim, Não] "
        "<" MtAttLarg:RemoveQuebra ">"))
    RemoveQuebra (if RemoveQuebra
            RemoveQuebra
            MtAttLarg:RemoveQuebra)
    MtAttLarg:RemoveQuebra RemoveQuebra)

;processa cada bloco
  (repeat (sslength ss)
    (setq ent (ssname ss 0)
      vla (vlax-ename->vla-object ent))

;caso o bloco tenha atributos,
;processa os atributos faça
    (if (= :vlax-true (vla-get-HasAttributes vla))
      (foreach att  (vlax-safearray->list
              (vlax-variant-value
            (vla-getattributes vla)))
    
;se o atributo é multilinhas, redefina a largura:
    (if (= :vlax-true (vla-get-mtextattribute att))
      (vla-put-mtextboundarywidth att largura))

;remova quebras de linha
    (if (= RemoveQuebra "Sim")
      (while (vl-string-search "\\P"
           (vla-get-textstring att))
        (vla-put-textstring
          att
          (vl-string-subst " " "\\P"
        (vla-get-textstring att)))))
    )
      )

;remove o primeiro elemento da seleção
;e vai pro próximo
    (ssdel ent ss)
    )
;restaura o controle de erros
  (tbn:error-restore)
)


Link(s) da(s) subrotina(s) usada(s):
tbn:error-init, tbn:error-restore

---

Para funcionar, você precisa salvar o código acima e também aquele indicado no link acima num mesmo arquivo *.lsp e pronto!!!

Você poderá usar o programa acima para ajeitar a largura dos blocos criados pelo CSONDAGEM, por exemplo. Ainda não testou este programa? Baixa ele já e testa!! Ele serve para criar blocos nos profileviews, indicando as sondagens feitas, veja uma imagem:

É isso, qualquer coisa, entre em contato!!

TBN2CAD - Novos comandos

E mais um, ou melhor 2 programas são adicionados ao TBN2CAD:

BLKPROPS - Ele extrai as propriedades (posição X,Y, escala e rotação) e atributos de blocos, criando uma lista. Isso para vários arquivos ao mesmo tempo!!!!

CHANGEBLK - Este usa os resultados do comando anterior e redefine os atributos e até substitui o bloco se necessário!!!

Imagine como fica fácil modificar listas de documentos!!

Renomear blocos anônimos

Hoje eu precisei renomear uns blocos anônimos, sabe aqueles, com nomes tipo *U32 e coisas do tipo Aí eu pensei, será que dá? Afinal, normalmente a gente só dá um purge e já era, hehehe Tentei o comando RENAME, mas... os nomes não estavam ali!!! Pensei num lispezinho básico, funcionou, heehehe
acho que poderá ser útil para mais alguem:

---

(DEFUN C:RENOMEIA (/ ENT NOME VLA ACAD DOC LST)
  (VL-LOAD-COM)
  (SETQ    ENT  (CAR (ENTSEL "\nSelecione o bloco"))
    NOME (GETSTRING t "\nQual o nome novo?")
    VLA  (VLAX-ENAME->VLA-OBJECT ENT)
    ACAD (VLAX-GET-ACAD-OBJECT)
    DOC  (VLA-GET-ACTIVEDOCUMENT ACAD)
    LST  (VLA-GET-BLOCKS DOC)
    REF  (VLA-ITEM LST (VLA-GET-NAME VLA))
  )
  (VLA-PUT-NAME REF NOME)
)

---

É isso!!, Só pra desenferrujar, hehhehe deverá funcionar no cad 2000 em diante