Translate

quarta-feira, 14 de dezembro de 2011

VBA: Criar um layer com cor em Autocad, GstarCad, Zwcad

Depois de ter colocado aqui uma rotina para criar um layer, temos agora a criação do layer e a cor que queremos que ela tenha.


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
Exit Sub
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

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

'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
Exit Sub
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

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

'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
Exit Sub
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

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

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


Para BricsCad (igual ao Autocad):

Public Sub layer()

Dim novalayer As String
Dim objlayer As AcadLayer

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

If "" = novalayer Then
Exit Sub
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

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

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

Boa programação

4 comentários:

  1. Respostas
    1. Caro Washington Araujo Melo,
      Obrigado pela sua visita. Volte sempre.
      Cumprimentos.

      Eliminar
  2. Francisco, você poderia postar um exemplo onde eu crio uma polyline, após isso crio ma layer com nome e cor definidos e depois disso, faço com que ela seja aplicada a polyline desenhada. Obrigado

    ResponderEliminar
    Respostas
    1. Caro Izaac Sena,
      Antes de mais, obrigado pela visita.
      Pode aproveitar aqui alguns ecemplos e tentar começar a sua própria programação.
      Se quiser algo em concreto como está pedindo eu posso dar o preço para esse trabalho.
      Cumprimentos.

      Eliminar