Translate

segunda-feira, 19 de dezembro de 2011

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

2 comentários:

  1. Onde posso achar um tutorial basico de VBA para Autocad para inicantes?

    ResponderEliminar
  2. Boas Luiz, obrigado pela visita, sinceramente não sei mas aqui tens alguns, experimenta uma procura na net, tipo autocad+VBA.
    Abraço

    ResponderEliminar