Excel escravizando o autocad

11 Comentários / Por /
Uma simples macro que exemplifica como o excel poderia criar layers no autocad!!

Veja o código…

'adicione as referencias:
'autocad 2008 type library (ou a sua versão)
'autocad/objectdbx commom 17.0 type libray (ou a sua versão do cad)

'define as variaveis globais a seguir
Dim Acad As IAcadApplication
Dim Thisdrawing As AcadDocument

'função que "linka" o cad QUE JÁ ESTÁ ABERTO
'se  nao estiver aberto, abra-o, ou implemente a função CREATEOBJECT
Function getacaddoc() As Boolean
  On Error GoTo erro
  'corrija aqui a versão correta do seu autocad
  '2009 => 17.2
  '2008 => 17.1
  '2007 => 17.0
  Set Acad = GetObject(, "Autocad.Application.17.1")
  
  'pega o dwg que estiver aberto
  Set Thisdrawing = Acad.ActiveDocument
ok:
  getacaddoc = True
  Exit Function
erro:
  getacaddoc = False
End Function

'função que obtem um layer pelo seu nome, criando caso nao exista
Function get_or_create_layer(name As String) As AcadLayer
  On Error GoTo cria
  Set get_or_create_layer = Thisdrawing.Layers.Item(name)
  Exit Function
cria:
  Set get_or_create_layer = Thisdrawing.Layers.Add(name)
End Function


'macro que cria layers no cad no dwg que estiver aberto
'defina a coluna "A" da planilha atual com os nomes
'defina a coluna "B" com as cores dos layers
'exemplo:
'   A       B
'1  teste   1
'2  jj      5
'3  lay2    66

Sub Teste()
  If getacaddoc() Then
    'MsgBox Thisdrawing.Name
  Else
    MsgBox "Erro:" & Err.Description
    Err.Clear
    Exit Sub
  End If
  
  Dim layer As AcadLayer
  Dim i As Long
  
  For i = 1 To 10
   If Me.Cells(i, 1) <> "" Then
     Set layer = get_or_create_layer(Me.Cells(i, 1))
     layer.Color = Me.Cells(i, 2)
   End If
  Next
  MsgBox "Pronto!!"
End Sub

Para usar, abra o excel, nele abra o editor do visual basic for applications e cole o código na “Plan1” por exemplo…

Em seguida, preencha a coluna “A” com o nomes dos layers a criar e na coluna “B” as cores, por exemplo, A1=lay1, A2=lay2 e B1=1 B2=3:

Depois aperte o “Play” hehehehe

Ah, claro, não esqueça de adicionar as referencias (menu ferramentas, referências no editor do vba):
autocad 2008 type library (ou a sua versão)
autocad/objectdbx commom 17.0 type libray (ou a sua versão do cad)
e claro, tenha o excel e o autocad já abertos nas planilhas e dwg de ua escolha!!

é isso…

11 comentários em “Excel escravizando o autocad”

  1. Anônimo

    Porque vc não usa o codigo de erro 429 e cada erro incrementa ate chegar a versão do cad correta e se passar digamos de 50 manda abrir o cad.
    Ex.

    'insera um modulo cole
    ' retire o form1 ou faça uma chamada call main
    Option Explicit
    Public cad As Object
    Public doc As Object
    Public corner1(0 To 2) As Double, corner2(0 To 2) As Double

    Dim circo As Object
    Const acWORLD = 0
    Const acUCS = 1
    Const pi = 3.14159265358979

    Sub Main()
    On Error GoTo ERRO2
    Dim raio
    Dim returnp(0 To 2) As Double
    Dim retur As Variant
    Dim sysVarName As String
    Dim sysVarData As Variant
    Dim intData As Integer, chat
    Dim varia() As Double
    Dim varia2() As Double
    Dim texto, num
    num = 10
    Set cad = GetObject(, "Autocad.Application." & num)
    Set doc = cad.ActiveDocument

    doc.Activate
    'AA = doc.ActiveLayer.Name
    Dim mode As Integer
    Dim Inter, Ext, Compri, NumDente, Incli, Tipo, Larg
    Dim modulo
    sysVarName = "UCSICON"
    intData = 3
    sysVarData = intData
    Call doc.SetVariable(sysVarName, sysVarData)
    Dim poli As Variant
    Dim passo, topo
    Dim poli2(0 To 0) As Object
    Dim poli3(0 To 0) As Object
    Dim altura As Double
    Dim ChaLarg, ChaAlt
    Dim chave As String
    ReDim varia(0 To 2) As Double
    Dim iincli
    Dim cabeça As Double, pe As Double
    doc.Utility.Prompt "Rotina para Geração de Rosca para AutoCad " & vbCrLf
    doc.Utility.Prompt "Autor: Ricardo doricid@gmail.com" & vbCrLf
    retur = doc.Utility.GetPoint(, "Indique Ponto Central para Engrenagem : ")

    'inter = modulo * ((numdente / Cos(incli)) – 2.333)
    Dim f As Double
    Dim k As Double

    f = 1.1666 * modulo
    k = modulo
    altura = modulo * 2.1666

    'erro na altura calculo do pe e da cabeça
    'Stop
    ERRO2:
    If solido Is Nothing Then
    Else
    solido.Visible = True: doc.Utility.Prompt "Modulo = " & modulo & vbCrLf
    corner2(0) = returnp(0) + Ext + 5: corner2(1) = returnp(1): corner2(2) = 0

    texto = texto & "Modulo = " & modulo & vbCrLf
    texto = texto & "Diametro Externo = " & Int(Ext * 200) / 100 & vbCrLf
    texto = texto & "Diametro Interno = " & Inter * 2 & vbCrLf
    texto = texto & "Diametro Primitivo = " & modulo * NumDente & vbCrLf
    If Val(iincli) <> 0 Then
    If iincli > 0 Then
    texto = texto & "Inclinação Direita= " & iincli & vbCrLf
    Else
    texto = texto & "Inclinação Esquerda= " & iincli & vbCrLf
    End If
    End If
    texto = texto & "Numero de Dentes = " & NumDente & vbCrLf
    texto = texto & "Espessura da Engrenagem = " & Compri & vbCrLf
    doc.modelspace.AddMText corner2, 300, texto
    End If
    Dim e

    If Err = 429 Then
    If num > 30 Then End
    num = num + 1: Resume

    End If
    End
    Resume
    End Sub

Deixe um comentário

Carrinho de compras
Rolar para cima