Noções básicas de Migração Autocad VBA para VB.net

Boas para quem quiser fica aqui o link da apresentação do Augusto Gonçalves em Português sobre Migração Autocad VBA para VB.net.

######## Apresentação ########

Ficheiros da apresentação: Download

São 48 minutos, aproveitem.

Bom trabalho

VBA: Create a Mtext (Autocad, ZWCad e Gstarcad)

Depois de alguma ausêsncia, volto a mostrar uma rotina em VBA.

Assim, a seguinte rotina em VBA serve para criarmos um texto pelo comando Mtext, espero que apreciem.

Para Autocad :

Public Sub NewMTEXT()

    Dim MTextObj As AcadMText
    Dim pontoinsercao(0 To 2) As Double
    Dim texto As String
    Dim alturatexto As Double
 
    pontoinsercao(0) = 0: pontoinsercao(1) = 0: pontoinsercao(2) = 0 'ponto de inserção
    alturatexto = 6 'altura do texto
    texto = "Loja dos Desenhadores" 'texto a escrever

    ' Criação do Mtext
     Set MTextObj = ThisDrawing.ModelSpace.AddMText(pontoinsercao, alturatexto, texto)

    'zoom Extents
     ZoomExtents

End Sub

Para GstarCad :

Public Sub NewMTEXT()

    Dim MTextObj As GcadMText
    Dim pontoinsercao(0 To 2) As Double
    Dim texto As String
    Dim alturatexto As Double

    pontoinsercao(0) = 0: pontoinsercao(1) = 0: pontoinsercao(2) = 0 'ponto de inserção
    alturatexto = 6 'altura do texto
    texto = "Loja dos Desenhadores" 'texto a escrever

    ' Criação do Mtext
     Set MTextObj = thisDrawing.ModelSpace.AddMText(pontoinsercao, alturatexto, texto)
   
     'zoom Extents
     ZoomExtents
   
End Sub

Para ZwCad : 

Public Sub NewMTEXT()

    Dim MTextObj As ZcadMText
    Dim pontoinsercao(0 To 2) As Double
    Dim texto As String
    Dim alturatexto As Double

    pontoinsercao(0) = 0: pontoinsercao(1) = 0: pontoinsercao(2) = 0 'ponto de inserção
    alturatexto = 6 'altura do texto
    texto = "Loja dos Desenhadores" 'texto a escrever

    ' Criação do Mtext
     Set MTextObj = ThisDrawing.ModelSpace.AddMText(pontoinsercao, alturatexto, texto)
   
     'zoom Extents
     ZoomExtents
   
End Sub

Obrigado

Boa programação

CAD Portugal para todos

Caros amigos, criei no Google + e no Facebbok uma comunidade, gostaria que todos participassem.

A ideia é para trocarmos ideias, sites e blogs,  truques e dicas, novidades, noticias, programações (lisp, VBA ou VB.net), etc., etc., etc. de qualquer tipo de CAD (Autocad, GstarCAD, ZWCad, etc etc.).
Podem também escrever sobre Civil3D, PowerCivil, Revit, Tekla, etc etc etc), e aproveitar este espaçõ para trocas de informação sobre estas novas ferramentas.
A ideia passa mesmo que seja uma comunidade de todos para todos, a única coisa que peço é inovação e respeito.

Fica também apresentado o logo escolhido criado pelo Filipe Francisco num concurso realizado pela comunidade.

Google + : CAD Portugal
Facebook : CAD Portugal

Obrigado.

Zwcad Open Xref (Xopen)

O Zwcad não trás o comando Xopen, o comando Xopen permite abrir um desenho que esteja por referência em outro desenho.

Fica aqui o código.

Sub XOPEN()
'abre referencia em outro desenho

Dim Documento As ZcadDocument
Dim PONTOBASE1 As ZcadPoint
Dim Xreferencia As ZcadEntity
Dim auxiliar As Integer
Dim Ficheiro As String
Dim FicheiroNome As String

On Error Resume Next

ThisDrawing.Utility.GetEntity Xreferencia, PONTOBASE1, "Escolha o Xref a abrir."

 If Xreferencia.IsLayout = False Then
    If Xreferencia.IsXRef = True Then
        Ficheiro = Xreferencia.Path
        FicheiroNome = ThisDrawing.Application.ActiveDocument.FullName
            If Left(Ficheiro, 1) = "." Then
            auxiliar = 0
            Do While Mid(FicheiroNome, Len(FicheiroNome) - auxiliar, 1) <> "\" And Mid(FicheiroNome, Len(FicheiroNome) - auxiliar, 1) <> "/"
            auxiliar = auxiliar + 1
                If Len(FicheiroNome) - auxiliar = 0 Then Exit Sub
            Loop
            Ficheiro = Mid(FicheiroNome, 1, Len(FicheiroNome) - auxiliar) + Right(Ficheiro, Len(Ficheiro) - 2)
            End If
            For Each Documento In Documents
                If Documento.FullName = Ficheiro Then
                    MsgBox ("O xref já se encontra aberto.")
                Exit Sub
            End If
            Next Documento
            ThisDrawing.Application.Documents.Open (Ficheiro)
    End If
  End If
End Sub


Obrigado

VBA: Rotina para apagar polilinhas de layer específica

A rotina que se segue em VBA, serve para apagar polilinhas existentes no desenho pertencente a uma layer específica.

Sub erasepolylayer()

' variaveis

 Dim ent As AcadEntity ' variavel entidade

 Dim lay As AcadLayer  'variavel layer

 Dim sset As AcadSelectionSet ' variavel selecção

 Set sset = ThisDrawing.SelectionSets.Add("GetLines")

 sset.Select acSelectionSetAll

 For Each ent In sset

  If TypeOf ent Is AcadLWPolyline Then

   If ent.Layer = "nome_da_layer" Then 'filtrar por nome de layer

    ent.Erase 'erase

   End If

  End If

 Next ent

End Sub

Obrigado

Obrigado

VBA: Rotina para desenhar Circunferência e Hatch (Routine to draw a circle and batch)

A rotina que se segue mostra como podemos desenhar uma circunferência e colocar um hatch no seu interior, mas dizendo que a boundarie é a própria circunferência.

Para Autocad :

Sub circhatch()

'variáveis
Dim centro As Variant
Dim raio As Double
Dim trama As AcadHatch
Dim limite As AcadCircle
Dim OuterLoop(0) As AcadEntity

'input para desenhar a circunferência
centro = ThisDrawing.Utility.GetPoint(, "Centro da primeira circunferência?")
raio = ThisDrawing.Utility.GetReal("Qual o raio?")

'desenha a circuferência atribuindo logo a fronteira do hatch
Set limite = ThisDrawing.ModelSpace.AddCircle(centro, raio)

'define e desenha o hatch
Set OuterLoop(0) = limite
Set trama = ThisDrawing.ModelSpace.AddHatch(acHatchPatternTypePreDefined, "SOLID", True)
trama.AppendOuterLoop (OuterLoop)
trama.Evaluate
trama.Update

ZoomExtents

End Sub

Para GstarCad :


Sub circhatch()

'variáveis
Dim centro As Variant
Dim raio As Double
Dim trama As GcadHatch
Dim limite As GcadCircle
Dim OuterLoop(0) As GcadEntidy

'input para desenhar a circunferência
centro = ThisDrawing.Utility.GetPoint(, "Centro da primeira circunferência?")
raio = ThisDrawing.Utility.GetReal("Qual o raio?")

'desenha a circuferência atribuindo logo a fronteira do hatch
Set limite = ThisDrawing.ModelSpace.AddCircle(centro, raio)

'define e desenha o hatch
Set OuterLoop(0) = limite
Set trama = ThisDrawing.ModelSpace.AddHatch(HatchPatternTypePreDefined, "SOLID", True)
trama.AppendOuterLoop (OuterLoop)
trama.Evaluate
trama.Update

ZoomExtents

End Sub

Para ZwCad : 

O Zwcad + alterou algumas coisas do seu código. A que mais se destaca é que deixou de ser ThisDocument e passou a ser ThisDrawing, uma grande ajuda para quem programa para vários Cad's. Outra das alterações é que deixámos de ter o ZWcad...... e passou a ser Zcad......
Fazendo estas chamadas de atenção fica aqui a primeira rotina feita para o ZWcad+ que se tornou muito melhor

Sub circhatch()

'variáveis
Dim centro As Variant
Dim raio As Double
Dim trama As ZcadHatch
Dim limite As ZcadCircle
Dim OuterLoop(0) As ZcadEntity

'input para desenhar a circunferência
centro = ThisDrawing.Utility.GetPoint(, "Centro da primeira circunferência?")
raio = ThisDrawing.Utility.GetReal("Qual o raio?")

'desenha a circuferência atribuindo logo a fronteira do hatcf
Set limite = ThisDrawing.ModelSpace.AddCircle(centro, raio)

'define e desenha o hatch
Set OuterLoop(0) = limite
Set trama = ThisDrawing.ModelSpace.AddHatch(zcHatchPatternTypePreDefined, "SOLID", True)
trama.AppendOuterLoop (OuterLoop)
trama.Evaluate
trama.Update

ZoomExtents

End Sub

Obrigado


Boa programação

VBA: Rotina Purgeall, Audit, Save e Quit no mesmo desenho em Autocad, GstarCad e ZwCad

A seguinte rotina em VBA serve para numa vez só realizarmos o PurgeAll, o audit e por fim gravarmos o desenho e fechar o Autocad.

Para Autocad :

Option Explicit

Sub audit()

ThisDrawing.PurgeAll

ThisDrawing.AuditInfo True

ThisDrawing.Save

ThisDrawing.Application.Quit

End Sub


Para GstarCad :


Option Explicit

Sub audit()

ThisDrawing.PurgeAll

ThisDrawing.AuditInfo True

ThisDrawing.Save

ThisDrawing.Application.Quit

End Sub


Para ZwCad : 

Option Explicit

Sub audit()

ThisDocument.SendCommand "-purge" & vbCr & "all" & vbCr & vbCr & "no" & vbCr

ThisDocument.SendCommand "-audit" & vbCr & "y" & vbCr

ThisDocument.Save

ThisDocument.Application.Quit

End Sub

Obrigado

Boa programação

VBA: Rotina com ciclo no Autocad, GstarCad e ZwCad

Na programação é muitas vezes necessário criar uma rotina com repetição que torna muito mais rápido uma ordem.

O ciclo é o For ... Next, espero que tirem o máximo proveito.

Para Autocad :

Sub ciclo()

Dim center(2) As Double
Dim x As Integer

center(0) = 0: center(1) = 0: center(2) = 0

For x = 1 To 26 Step 3
thisDrawing.ModelSpace.AddCircle center, x
Next

End Sub




Para GstarCad :

Sub ciclo()

Dim center(2) As Double
Dim x As Integer

center(0) = 0: center(1) = 0: center(2) = 0

For x = 1 To 26 Step 3
thisDrawing.ModelSpace.AddCircle center, x
Next

End Sub




Para ZwCad : 

Sub ciclo()

Dim center(2) As Double
Dim x As Integer

center(0) = 0: center(1) = 0: center(2) = 0

For x = 1 To 26 Step 3
ThisDocument.ModelSpace.AddCircle center, x
Next

End Sub

Obrigado

Boa programação

VBA: Somar textos em Autocad, GstarCad e ZwCad

Esta rotina em VBA mostra como juntar várias parcelas de texto num único apenas.

Para Autocad :

Option Explicit

Public Sub Somar_textos()

Dim PontoInicial(0 To 2) As Double
Dim Textos As String
Dim NovoTexto As AcadText

PontoInicial(0) = 0
PontoInicial(1) = 0
PontoInicial(2) = 0
Textos = "Loja" & " dos " & "Desenhadores"

Set NovoTexto = ThisDrawing.ModelSpace.AddText(Textos, PontoInicial, 1)

ZoomExtents

End Sub

Para GstarCad :

Option Explicit

Public Sub Somar_textos()

Dim PontoInicial(0 To 2) As Double
Dim Textos As String
Dim NovoTexto As GcadText

PontoInicial(0) = 0
PontoInicial(1) = 0
PontoInicial(2) = 0
Textos = "Loja" & " dos " & "Desenhadores"

Set NovoTexto = thisDrawing.ModelSpace.AddText(Textos, PontoInicial, 1)

ZoomExtents

End Sub

Para ZwCad : 

Option Explicit
Public Sub Somar_textos()

Dim PontoInicial(0 To 2) As Double
Dim Textos As String
Dim NovoTexto As ZwcadText

PontoInicial(0) = 0
PontoInicial(1) = 0
PontoInicial(2) = 0
Textos = "Loja" & " dos " & "Desenhadores"

Set NovoTexto = ThisDocument.ModelSpace.AddText(Textos, PontoInicial, 1)

End Sub

Obrigado

Boa programação

VBA: Criar uma polilinha e rodar em Autocad, GstarCad e ZwCad

Esta rotina em VBA mostra como podemos construir um polígono, neste caso um triângulo e por fim rodamos com um basepoint (1,2,0) e ângulo de 45graus.

Para Autocad :

Sub Rotate_Polilinha()

    Dim polilinha As Acadlwpolyline
    Dim ponto(0 To 5) As Double
    ponto(0) = 0: ponto(1) = 1
    ponto(2) = 2: ponto(3) = 1
    ponto(4) = 1: ponto(5) = 3
    Set polilinha = ThisDrawing.ModelSpace.AddLightWeightPolyline(ponto)
    polilinha.Closed = True
   
    Dim basePoint(0 To 2) As Double
    Dim Angle As Double
    basePoint(0) = 1: basePoint(1) = 2: basePoint(2) = 0
    Angle = 0.7853981
    polilinha.Rotate basePoint, Angle
  
    ZoomExtents

End Sub

Para GstarCad :

Sub Rotate_Polilinha()

    Dim polilinha As Gcadlwpolyline
    Dim ponto(0 To 5) As Double
    ponto(0) = 0: ponto(1) = 1
    ponto(2) = 2: ponto(3) = 1
    ponto(4) = 1: ponto(5) = 3
    Set polilinha = thisDrawing.ModelSpace.AddLightWeightPolyline(ponto)
    polilinha.Closed = True
   
    Dim basePoint(0 To 2) As Double
    Dim Angle As Double
    basePoint(0) = 1: basePoint(1) = 2: basePoint(2) = 0
    Angle = 0.7853981
    polilinha.Rotate basePoint, Angle
  
    ZoomExtents

End Sub

Para ZwCad : 

Sub Rotate_Polilinha()

    Dim polilinha As Zwcadlwpolyline
    Dim ponto(0 To 5) As Double
    ponto(0) = 0: ponto(1) = 1
    ponto(2) = 2: ponto(3) = 1
    ponto(4) = 1: ponto(5) = 3
    Set polilinha = ThisDocument.ModelSpace.AddLightWeightPolyline(ponto)
    polilinha.Closed = True
   
    Dim basePoint(0 To 2) As Double
    Dim Angle As Double
    basePoint(0) = 1: basePoint(1) = 2: basePoint(2) = 0
    Angle = 0.7853981
    polilinha.Rotate basePoint, Angle
  
    ZoomExtents

End Sub

Obrigado.

Boa programação

VBA: Enviar ordem para a linha de comando no Autocad, GstarCad e ZwCad

A rotina apresentada mostra-nos de como podemos enviar uma ordem directamente para a linha de comando, neste caso um circulo com um zoom extents e um regen.

Para Autocad :

Sub ordem_commandline()
   ThisDrawing.SendCommand "_Circle" & vbCr & "5,4,0" & vbCr & "3.5" & vbCr
   ThisDrawing.SendCommand "_zoom" & vbCr & "e" & vbCr
   ThisDrawing.Regen acAllViewports
 End Sub

Para GstarCad :

Sub ordem_commandline()
   ThisDrawing.SendCommand "_Circle" & vbCr & "5,4,0" & vbCr & "3.5" & vbCr
   ThisDrawing.SendCommand "_zoom" & vbCr & "e" & vbCr
   ThisDrawing.Regen acAllViewports
 End Sub

Para ZwCad : 

Sub ordem_commandline()
   ThisDocument.SendCommand "_Circle" & vbCr & "5,4,0" & vbCr & "3.5" & vbCr
   ThisDocument.SendCommand "_zoom" & vbCr & "e" & vbCr
   ThisDocument.Regen acAllViewports
 End Sub

Obrigado.

Boa programação

VBA: Criar circulo, seleccionar todas as entidades existentes e mover em Autocad, GstarCad, ZwCad e BricsCad

Na continuação do último post sobre VBA, fica um exemplo de uma rotina para  fazer um circulo, sendo de seguida seleccionado tudo o que existe no desenho e movendo.

Para Autocad :

 Sub Moveall_Circulo()

    Dim CirculoObj As AcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set CirculoObj = ThisDrawing.ModelSpace.AddCircle(centro, raio)

    Dim selectset As AcadSelectionSet
    Set selectset = ThisDrawing.SelectionSets.Add("selectset2")
    selectset.Select acSelectionSetAll

    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 30: ponto2(1) = 20: ponto2(2) = 0

    For Each ent In selectset
        ent.Move ponto1, ponto2
    Next
   
    ZoomExtents

End Sub

Para GstarCad :

Sub Moveall_Circulo()

    Dim CirculoObj As GcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set CirculoObj = thisDrawing.ModelSpace.AddCircle(centro, raio)

    Dim selectset As GcadSelectionSet
    Set selectset = thisDrawing.SelectionSets.Add("selectset2")
    selectset.Select acSelectionSetAll

    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 30: ponto2(1) = 20: ponto2(2) = 0

    For Each ent In selectset
        ent.Move ponto1, ponto2
    Next
   
    ZoomExtents

End Sub

Para ZwCad : 

  Sub Moveall_Circulo()

    Dim CirculoObj As ZwcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set CirculoObj = ThisDocument.ModelSpace.AddCircle(centro, raio)

    Dim selectset As ZwcadSelectionSet
    Set selectset = ThisDocument.SelectionSets.Add("selectset")
    selectset.Select zcSelectionSetAll

    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 30: ponto2(1) = 20: ponto2(2) = 0

    For Each ent In selectset
        ent.Move ponto1, ponto2
    Next
  
    ZoomExtents

End Sub

Obrigado.

Boa programação

VBA: Criar Circulo e mover em Autocad, GstarCad, ZwCad e BricsCad

Fica aqui uma rotina para  fazer um circulo e depois o move, infelizmente continuo sem experimentar no ZwCad e no BricsCad.

Para Autocad :

Sub Move_Circulo()

    Dim CirculoObj As AcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set Circulo = ThisDrawing.ModelSpace.AddCircle(centro, raio)
   
    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 10: ponto2(1) = 20: ponto2(2) = 0
  
    Circulo.Move ponto1, ponto2
    ZoomExtents
  
End Sub

Para GstarCad :


Sub Move_Circulo()

    Dim CirculoObj As GcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set Circulo = thisDrawing.ModelSpace.AddCircle(centro, raio)
   
    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 10: ponto2(1) = 20: ponto2(2) = 0
  
    Circulo.Move ponto1, ponto2
    ZoomExtents
  
End Sub

Para ZwCad : 
(Infelizmente não tenho possibilidade de experimentar neste Cad fica a possível solução)

Sub Move_Circulo()

    Dim CirculoObj As ZwcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set Circulo = ThisDocument.ModelSpace.AddCircle(centro, raio)
   
    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 10: ponto2(1) = 20: ponto2(2) = 0
  
    Circulo.Move ponto1, ponto2
    ZoomExtents
  
End Sub

Para Bricscad :
(Infelizmente não tenho possibilidade de experimentar neste Cad fica a possível solução)


Sub Move_Circulo()

    Dim CirculoObj As AcadCircle
    Dim centro(0 To 2) As Double
    Dim raio As Double
    centro(0) = 3#: centro(1) = 1#: centro(2) = 0#
    raio = 2.5
    Set Circulo = ThisDrawing.ModelSpace.AddCircle(centro, raio)
   
    Dim ponto1(0 To 2) As Double
    Dim ponto2(0 To 2) As Double
    ponto1(0) = 0: ponto1(1) = 0: ponto1(2) = 0
    ponto2(0) = 10: ponto2(1) = 20: ponto2(2) = 0
  
    Circulo.Move ponto1, ponto2
    ZoomExtents
  
End Sub

Obrigado.

Boa programação

VBA: Inserir texto no Autocad, GstarCad, ZwCad

Hoje mostro como podemos inserir texto, infelizmente continuo sem conseguir experimentar no ZwCad e no BricsCad.

Para Autocad :

Sub add_texto()

Dim Txt As AcadText

Dim ponto(0 To 2) As Double

Dim stringtxt As String

Dim alturatxt As Double

stringtxt = "Autocad"

ponto(0) = 5

ponto(1) = 3

ponto(2) = 0

alturatxt = 1

Set Txt = ThisDrawing.ModelSpace.AddText(stringtxt, ponto, alturatxt)

ZoomExtents

End Sub

Para GstarCad :

Sub add_texto()

Dim Txt As GcadText

Dim ponto(0 To 2) As Double

Dim stringtxt As String

Dim alturatxt As Double

stringtxt = "GSTARcad"

ponto(0) = 5

ponto(1) = 3

ponto(2) = 0

alturatxt = 1

Set Txt = thisDrawing.ModelSpace.AddText(stringtxt, ponto, alturatxt)

ZoomExtents

End Sub

Para ZwCad : 

(Infelizmente não tenho possibilidade de experimentar neste Cad fica a possível solução)

Sub add_texto()

Dim Txt As ZwcadText

Dim ponto(0 To 2) As Double

Dim stringtxt As String

Dim alturatxt As Double

stringtxt = "ZWcad"

ponto(0) = 5

ponto(1) = 3

ponto(2) = 0

alturatxt = 1

Set Txt = ThisDocument.ModelSpace.AddText(stringtxt, ponto, alturatxt)

ZoomExtents

End Sub

Para Bricscad :

(Infelizmente não tenho possibilidade de experimentar neste Cad fica a possível solução)

Sub add_texto()

Dim Txt As AcadText

Dim ponto(0 To 2) As Double

Dim stringtxt As String

Dim alturatxt As Double

stringtxt = "Autocad"

ponto(0) = 5

ponto(1) = 3

ponto(2) = 0

alturatxt = 1

Set Txt = ThisDrawing.ModelSpace.AddText(stringtxt, ponto, alturatxt)

ZoomExtents

End Sub

Obrigado a todos.

Boa programação