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
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
Onde posso achar um tutorial basico de VBA para Autocad para inicantes?
ResponderEliminarBoas Luiz, obrigado pela visita, sinceramente não sei mas aqui tens alguns, experimenta uma procura na net, tipo autocad+VBA.
ResponderEliminarAbraço