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: 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

VBA: Regen em Viewports em Autocad, GstarCad, ZwCad e BricsCad

Fica aqui uma rotina para  fazer o Regen em uma Viewport ou em várias, infelizmente não tenho onde experimentar no ZwCad e no BricsCad.

Para Autocad :

Sub regenVP()

ThisDrawing.Regen (gcActiveViewport) 'regen ao viewport activo
ThisDrawing.Regen (gcAllViewports) 'regen a todos os viewports

End Sub


 ou


Sub regenVP()

ThisDrawing.Regen (acActiveViewport) 'regen ao viewport activo
ThisDrawing.Regen (acAllViewports) 'regen a todos os viewports

End Sub


Para GstarCad :




Sub regenVP()

ThisDrawing.Regen (gcActiveViewport) 'regen ao viewport activo
ThisDrawing.Regen (gcAllViewports) 'regen a todos os viewports

End Sub

 ou

Sub regenVP()

ThisDrawing.Regen (acActiveViewport) 'regen ao viewport activo
ThisDrawing.Regen (acAllViewports) 'regen a todos os viewports

End Sub

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

Sub regenVP()

ThisDocument.Regen (zcActiveViewport) 'regen ao viewport activo
ThisDocument.Regen (zcAllViewports) 'regen a todos os viewports

End Sub


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



Sub regenVP()

ThisDrawing.Regen (acActiveViewport) 'regen ao viewport activo
ThisDrawing.Regen (acAllViewports) 'regen a todos os viewports

End Sub




Obrigado a todos.

Boa programação

VBA: Inserir imagem Autocad, GstarCad, ZwCad

Hoje, vou mostrar como podemos fazer uma rotina em VBA para inserir uma imagem.

Imaginem que têm uma rotina que vos prepara a folha de trabalho, onde têm de incluir uma imagem no logo.

Para Autocad :

Option Explicit

Sub inserir_imagem()
Dim insertionPoint(0 To 2) As Double
Dim scalefactor As Double
Dim rotationAngle As Double
Dim nomeimagem As String

Dim rasterOBj As AcadRasterImage
nomeimagem = "c:\imagem.jpg"

insertionPoint(0) = 12#: insertionPoint(1) = 2#: insertionPoint(2) = 0#
scalefactor = 1#
rotationAngle = 0

Set rasterOBj = ThisDrawing.ModelSpace.AddRaster(nomeimagem, insertionPoint, scalefactor, rotationAngle)

End Sub


Para GstarCad :


Option Explicit

Sub inserir_imagem()

Dim insertionPoint(0 To 2) As Double
Dim scalefactor As Double
Dim rotationAngle As Double
Dim nomeimagem As String

Dim rasterObj As GcadRasterImage
nomeimagem = "c:\imagem.jpg"

insertionPoint(0) = 12#: insertionPoint(1) = 2#: insertionPoint(2) = 0#
scalefactor = 1#
rotationAngle = 0

Set rasterObj = thisDrawing.ModelSpace.AddRaster(nomeimagem, insertionPoint, scalefactor, rotationAngle)


End Sub

Para ZwCad : 

Option Explicit

Sub inserir_imagem()
Dim insertionPoint(0 To 2) As Double
Dim scalefactor As Double
Dim rotationAngle As Double
Dim nomeimagem As String

Dim rasterOBj As ZwcadRasterImage
nomeimagem = "c:\imagem.jpg"

insertionPoint(0) = 12#: insertionPoint(1) = 2#: insertionPoint(2) = 0#
scalefactor = 1#
rotationAngle = 0

Set rasterOBj = ThisDocument.ModelSpace.AddRaster(nomeimagem, insertionPoint, scalefactor, rotationAngle)

End Sub


Para Bricscad :


Option Explicit

Sub inserir_imagem()
Dim insertionPoint(0 To 2) As Double
Dim scalefactor As Double
Dim rotationAngle As Double
Dim nomeimagem As String

Dim rasterOBj As AcadRasterImage
nomeimagem = "c:\imagem.jpg"

insertionPoint(0) = 12#: insertionPoint(1) = 2#: insertionPoint(2) = 0#
scalefactor = 1#
rotationAngle = 0

Set rasterOBj = ThisDrawing.ModelSpace.AddRaster(nomeimagem, insertionPoint, scalefactor, rotationAngle)

End Sub


Obrigado a todos.

Boa programação

VBA: Purge All em Autocad, GstarCad, Zwcad e Bricscad

Depois das festas volto a publicar aqui no Blog, hoje, gostaria de mostrar como podemos fazer uma rotina em VBA para os vários CADs, infelizmente não consegui que no ZwCad funcionasse. Se alguém tiver a solução pode publicá-la.

Para Autocad, GstarCad e Bricscad :

Option Explicit

Sub Purge_all()

ThisDrawing.PurgeAll

End Sub

Para ZwCad: 
(Obrigado do Arq alexandre pela dica. O Arq. Alexandre é o representante do ZwCad em Portugal pela empresa IberCad).

Option Explicit

Sub Purge_all()

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


End Sub


Obrigado a todos e um bom ano.

Boa programação

VBA: Criar um layer+ cor+linetype em Autocad, GstarCad, Zwcad e Bricscad

Depois de ter colocado aqui a rotina para criar um layer com cor, temos agora a criação do layer com a cor e com a linetype.


Fica aqui disponível para copy /past directamente para o editor.
As rotinas têm as diferenças entre o Autocad e cada um dos outros programas marcadas a vermelho.

Para Autocad:

Public Sub layer()

Dim novalayer As String
Dim objlayer As AcadLayer

novalayer = InputBox("Nome da Nova Layer ?")

If "" = novalayer Then
End If

On Error Resume Next

Set objlayer = ThisDrawing.Layers(novalayer)
If objlayer Is Nothing Then
Set objlayer = ThisDrawing.Layers.Add(novalayer)
If objlayer Is Nothing Then
MsgBox "Não é possivel criar a layer '" & novalayer & "'"
Else
MsgBox "Layer Nova Criada '" & objlayer.Name & "'"
End If
Else
MsgBox "O Layer Já Existe"
End If

'Color

Set NovaCor = New AcadAcCmColor
NovaCor.ColorMethod = acColorMethodByRGB
ncolor = CLng(InputBox(vbCr & "Qual o número da cor para o layer: ", "Layer Color", "10"))
If ncolor < 0 Or ncolor > 256 Then
MsgBox "Use o número da cor entre o 0 e o 256"
End If

NovaCor.ColorIndex = ncolor
objlayer.TrueColor = NovaCor

'Linetype

Dim objLinetype As AcadLineType
Dim Nlinha As String

Nlinha = InputBox("Enter a new Linetype name: ")
If "" = Nlinha Then Exit Sub
Set objLinetype = ThisDrawing.Linetypes(Nlinha)
If objLinetype Is Nothing Then
ThisDrawing.Linetypes.Load Nlinha, "acad.lin"
End If
objlayer.Linetype = Nlinha

'coloca a nova layer como current
ThisDrawing.ActiveLayer = objlayer

End Sub

Para GstarCad:

Public Sub layer()

Dim novalayer As String
Dim objlayer As GcadLayer

novalayer = InputBox("Nome da Nova Layer ?")

If "" = novalayer Then
End If

On Error Resume Next

Set objlayer = thisDrawing.Layers(novalayer)
If objlayer Is Nothing Then
Set objlayer = thisDrawing.Layers.Add(novalayer)
  If objlayer Is Nothing Then
  MsgBox "Não é possivel criar a layer '" & novalayer & "'"
  Else
  MsgBox "Layer Nova Criada '" & objlayer.Name & "'"
  End If
Else
MsgBox "O Layer Já Existe"
End If

'Color

Set NovaCor = New GcadAcCmColor
NovaCor.ColorMethod = acColorMethodByRGB
ncolor = CLng(InputBox(vbCr & "Qual o número da cor para o layer: ", "Layer Color", "10"))
If ncolor < 0 Or ncolor > 256 Then
MsgBox "Use o número da cor entre o 0 e o 256"
End If

NovaCor.ColorIndex = ncolor
objlayer.TrueColor = NovaCor

'Linetype

Dim objLinetype As GcadLineType
Dim Nlinha As String

'Aqui convém colocar ucase para que o Gstarcad reconheça o tipo de linha
Nlinha = UCase(InputBox("Enter a new Linetype name: "))
If "" = Nlinha Then Exit Sub
Set objLinetype = thisDrawing.Linetypes(Nlinha)
If objLinetype Is Nothing Then
thisDrawing.Linetypes.Load Nlinha, "ICAD.LIN"
End If
objlayer.Linetype = Nlinha

'coloca a nova layer como current
thisDrawing.ActiveLayer = objlayer

End Sub

Para ZwCad:

Public Sub layer()

Dim novalayer As String
Dim objlayer As ZwcadLayer

novalayer = InputBox("Nome da Nova Layer ?")

If "" = novalayer Then
End If

On Error Resume Next

Set objlayer = ThisDocument.Layers(novalayer)
If objlayer Is Nothing Then
Set objlayer = ThisDocument.Layers.Add(novalayer)
  If objlayer Is Nothing Then
  MsgBox "Não é possivel criar a layer '" & novalayer & "'"
  Else
  MsgBox "Layer Nova Criada '" & objlayer.Name & "'"
 End If
Else
MsgBox "O Layer Já Existe"
End If

'Color

Set NovaCor = New ZwcadAcCmColor
NovaCor.ColorMethod = acColorMethodByRGB
ncolor = CLng(InputBox(vbCr & "Qual o número da cor para o layer: ", "Layer Color", "10"))
If ncolor < 0 Or ncolor > 256 Then
MsgBox "Use o número da cor entre o 0 e o 256"
End If

NovaCor.ColorIndex = ncolor
objlayer.TrueColor = NovaCor

'Linetype

Dim objLinetype As ZwcadLinetype
Dim Nlinha As String

Nlinha = InputBox("Enter a new Linetype name: ")
If "" = Nlinha Then Exit Sub
Set objLinetype = ThisDocument.Linetypes(Nlinha)
If objLinetype Is Nothing Then
ThisDocument.Linetypes.Load Nlinha, "Zwcad.lin"
End If
objlayer.Linetype = Nlinha

'coloca a nova layer como current
ThisDocument.ActiveLayer = objlayer

End Sub

Para BricsCad:

Public Sub layer()

Dim novalayer As String
Dim objlayer As AcadLayer

novalayer = InputBox("Nome da Nova Layer ?")

If "" = novalayer Then
End If

On Error Resume Next

Set objlayer = ThisDrawing.Layers(novalayer)
If objlayer Is Nothing Then
Set objlayer = ThisDrawing.Layers.Add(novalayer)
  If objlayer Is Nothing Then
  MsgBox "Não é possivel criar a layer '" & novalayer & "'"
  Else
  MsgBox "Layer Nova Criada '" & objlayer.Name & "'"
  End If
Else
MsgBox "O Layer Já Existe"
End If

'Color

Set NovaCor = New AcadAcCmColor
NovaCor.ColorMethod = acColorMethodByRGB
ncolor = CLng(InputBox(vbCr & "Qual o número da cor para o layer: ", "Layer Color", "10"))
If ncolor < 0 Or ncolor > 256 Then
MsgBox "Use o número da cor entre o 0 e o 256"
End If

NovaCor.ColorIndex = ncolor
objlayer.TrueColor = NovaCor

'Linetype

Dim objLinetype As AcadLineType
Dim Nlinha As String

Nlinha = InputBox("Enter a new Linetype name: ")
If "" = Nlinha Then Exit Sub
Set objLinetype = ThisDrawing.Linetypes(Nlinha)
If objLinetype Is Nothing Then
ThisDrawing.Linetypes.Load Nlinha, "iso.lin"
End If
objlayer.Linetype = Nlinha

'coloca a nova layer como current
ThisDrawing.ActiveLayer = objlayer

End Sub


Boa programação