Exportar Texto do Excel para AutoCAD via VBA

  • Ola,


    Preciso exportar texto de algumas celulas para o AutoCAD e gostaria de fazer isso via VBA.

    Alguem sabe como faze-lo?


    Por exemplo

    Na celula B4 eu tenho o texto: "Armação Secundária"

    Este texto iria para a área do autoCad automaticamente.


    Pela Internet eu achei o seguinte código, mas NÃO funciona:


    Opção Explicit





    Sub Ex_Acad()





    Dim oAcad As Object

    Dim oDoc As AcadDocument

    Dim oPaper As AcadPaperSpace

    Dim Pts1(0 To 2) As Double

    Dim Pts2(0 To 2) As Double

    Dim Pts3(0 To 2) As Double

    Dim Pts4(0 To 2) Como Dupla

    Dim Pts5(0 A 2) Como Dupla

    Dim Pts6(0 A 2) Como Dupla

    Dim Pts7(0 A 2) Como Dupla

    Dim Pts8(0 A 2) Como Dupla

    Dim Pontos(0 A 43) Como Dupla

    Dim blockObj As AcadBlock

    Dim blockRefObj As AcadBlockReference

    Dim pLine As AcadLWPolyline

    Dim x As Double

    Dim i As Integer

    Dim sht As Worksheet

    Dim dtxt As AcadText

    Dim mtxt As AcadMText

    Dim varAtt As Variant





    On Error GoTo ERRORMSG 'Se o Autocad não estiver rodando, mensagem e sair

    Set oAcad = GetObject(, "Autocad.Application") 'Obter a instância aberta do AutoCad

    On Error GoTo 0 'Reset Error





    Set oDoc = oAcad.ActiveDocument 'Set the Active Desenho

    Set oPaper = oDoc.PaperSpace

    Set sht = ActiveWorkbook.Sheets(1) 'Definir a planilha





    If sht.Cells(4, 2) = "" Then Exit Sub 'Check for Info to Export - If Cell B4 is Blank Quit





    oDoc. ActiveLayer = oDoc.Layers("0_TABL") 'Definir Camada





    Pts1(0) = 0: Pts1(1) = 0: Pts1(2) = 0 'Definir Ponto de Inserção para





    Conjunto de Blocos Temp blockObj = oDoc.Blocks.Add(Pts1 , "Temperatura") 'Criar Bloqueio Temporário para Fronteira





    Pontos(0) = 0: Pontos(1) = 0: Pontos(2) = 0: Pontos(3) = 9,21: Pontos(4) = 12,4: Pontos(5) = 9,21

    Pontos(6) = 12,4: Pontos( 7) = 0: Pontos(8) = 12,4: Pontos(9) = 9,21: Pontos(10) = 82,4: Pontos(11) = 9,21

    Pontos(12) = 82,4: Pontos(13) = 0: Pontos(14) = 82,4: Pontos(15) = 9,21: Pontos(16) = 92,4: Pontos(17) = 9,21

    Pontos(18) = 92,4: Pontos(19) = 0: Pontos(20) = 92,4: Pontos(21) = 9,21 : Pontos(22) = 122,4: Pontos(23) = 9,21

    Pontos(24) = 122,4: Pontos(25) = 0: Pontos(26) = 122,4: Pontos(27) = 9,21: Pontos(28) = 152,4: Pontos (29) = 9,21

    Pontos(30) = 152,4: Pontos(31) = 0: Pontos(32) = 152,4: Pontos(33) = 9,21: Pontos(34) = 164,4: Pontos(35) = 9,21

    Pontos(36) = 164,4: Pontos(37) = 0: Pontos(38) = 164,4: Pontos(39) = 9,21: Pontos(40) = 180,8: Pontos(41) = 9,21

    Pontos(42) = 180,8: Pontos( 43) = 0





    Defina pLinha = blocoObj. AddLightWeightPolyline(Points) 'Desenhar Borda





    Pts1(0) = 205: Pts1(1) = 71.6: Pts1(2) = 0 'Ponto de inserção para conjunto de blocos de cabeçalho





    blockRefObj = oPaper.InsertBlock(Pts1, "TABL_poz", 1#, 1 #, 1#, 0) 'Insira seu bloco de cabeçalho





    Pts1(0) = 24.2: Pts1(1) = 72.79: Pts1(2) = 0 'Defina pontos de partida para deslocamento

    Pts2(0) = 30.4: Pts2(1) = 75,67: Pts2(2) = 0

    Pts3(0) = 38,6: Pts3(1) = 77,4: Pts3(2) = 0

    Pts4(0) = 111,6: Pts4(1) = 76,16: Pts4(2) = 0

    Pts5( 0) = 131,6: Pts5(1) = 77,4: Pts5(2) = 0

    Pts6(0) = 161,6: Pts6(1) = 77,4: Pts6(2) = 0

    Pts7(0) = 187,35: Pts7(1) = 76,21: Pts7(2) = 0

    Pts8(0) = 203,03: Pts8(1 ) = 76.16: Pts8(2) = 0





    x = 9.21 'Offset for Temp Block





    oDoc.ActiveTextStyle = oDoc.TextStyles("Romans") 'Set Text Style





    For i = 4 To sht.Cells(100, 2).End( xlUp). Etapa 2

    da Linha Pts1(1) = Pts1(1) + x: Pts2(1) = Pts2(1) + x: Pts3(1) = Pts3(1) + x: Pts4(1) = Pts4(1) ) + x 'Definir Pontos de Inserção (Offset)

    Pts5(1) = Pts5(1) + x: Pts6(1) = Pts6(1) + x: Pts7(1) = Pts7(1) + x: Pts8(1) = Pts8(1) + x Set blockRefObj = oPaper.InsertBlock(Pts1, "Temp", 1#, 1#, 1#, 0) 'Inserir Borda

       



       

    Set dtxt = oPaper.AddText(sht.Cells(i, 2).Text, Pts2, 3.5) 'Insert Text

    dtxt.Alignment = acAlignmentCenter 'Set Text Alignment

    dtxt.TextAlignmentPoint = Pts2

    dtxt.Color = acCyan

    Set mtxt = oPaper.AddMText (Pts3, 70, sht.Cells(i, 3).Text) 'Inserir texto

    mtxt.Height = 2.4

    mtxt.AttachmentPoint = acAttachmentPointMiddleLeft

    mtxt.InsertionPoint = Pts3

    Definir dtxt = oPaper.AddText(sht.Cells(i, 6). Texto, Pts4, 2.4) 'Inserir texto

    dtxt.Alignment = acAlignmentCenter 'Definir alinhamento de texto

    dtxt.TextAlignmentPoint = Pts4

    Definir mtxt = oPaper.AddMText(Pts5, 30, sht.Cells(i, 4).Text) 'Inserir texto

    mtxt.Height = 2.4

    mtxt.AttachmentPoint = acAttachmentPointMiddleCenter

    mtxt .InsertionPoint = Pts5

    Set mtxt = oPaper.AddMText(Pts6, 30, sht.Cells(i, 5).Text) 'Insertion Text

    mtxt.Height = 2.4

    mtxt.AttachmentPoint = acAttachmentPointMiddleCenter

    mtxt.InsertionPoint = Pts6

    Set dtxt = oPaper.AddText (sht.Cells(i, 7).Texto, Pts7, 2.4) 'Inserir texto

    dtxt.Alignment = acAlignmentRight 'Definir alinhamento de texto

    dtxt.TextAlignmentPoint = Pts7

    Definir dtxt = oPaper.AddText(sht.Cells(i, 8).Text, Pts8, 2.4) 'Inserir texto

    dtxt.Alignment = acAlignmentRight 'Definir alinhamento de texto

    dtxt. TextAlignmentPoint = Pts8





    Próximo i





    oDoc.ActiveLayer = oDoc.Layers("2DM_OBV") 'Definir Camada para Bloco de Resumo de Peso





    Pts1(0) = Pts1(0) + 140.36: Pts1(1) = Pts1(1) + 15 'Definir Inserção para conjunto de blocos de resumo de peso





    blockRefObj = oPaper.InsertBlock(Pts1, "TABL_suma", 1#, 1#, 1#, 0) 'Inserir bloco de resumo de peso

    varAtt = blockRefObj.GetAttributes

    varAtt(0).TextString = sht.Cells(100, 7).End(xlUp).Text 'Modificar Atributo oDoc.ActiveLayer = oDoc.Layers("0") 'Reset Default Layer Exit Sub ERRORMSG: 'Se o Autocad não estiver aberto, isso executará MsgBox "Autocad deve estar aberto" End Sub

       

















       


Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!