MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Exportar tabela para Word

    Compartilhe

    diogodmc
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 13
    Registrado : 07/03/2017

    Exportar tabela para Word

    Mensagem  diogodmc em 8/3/2018, 18:47

    Pessoal, boa tarde.

    Estou passando por uma dificuldade, estou fazendo um sistema que após o preenchimentos dos campos pelo usuário, gera um documento em Word e PDF.

    Preciso que uma tabela sai no documento gerado e não estou obtendo sucesso, será que alguém consegue identificar o problema no meu código?

    Vamos lá, o modo que estou fazendo até o momento é o seguinte:

    1ª - Exporto as informações que preciso para uma tabela no excel, tenho uma macro no excel que cola a tabela em um indicador salvo no meu Word.

    Código:
    Sub PreencheTabela()

     'Name of the existing Word doc.
        Const stWordReport As String = "Template_Aditivo.docm"

        'Word objects.
        Dim wdApp As Word.Application
        Dim wdDoc As Word.Document
        Dim wdbmRange As Word.Range

        'Excel objects.
        Dim wbBook As Workbook
        Dim wsSheet As Worksheet
        Dim rnReport As Range

        'Initialize the Excel objects.
        Set wbBook = ThisWorkbook
        Set wsSheet = wbBook.Worksheets("SEL_Report")
        Set rnReport = wsSheet.Range("Tabela1")

        'Initialize the Word objets.
        Set wdApp = New Word.Application
        Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\PastaTemporaria - diogo.mattos" & "\" & stWordReport)
    '    Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
        Set wdbmRange = wdDoc.Bookmarks("Teste_Tabela").Range
        
        'If the macro has been run before, clean up any artifacts before trying to paste the table in again.
    '    On Error Resume Next
    '    With wdDoc.InlineShapes(1)
    '        .Select
    '        .Delete
    '    End With
    '    On Error GoTo 0

        'Turn off screen updating.
        Application.ScreenUpdating = False
        'Copy the report to the clipboard.
        rnReport.Copy

        'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
        With wdbmRange
            .Select
            .Paste
            .Font.Size = 8
            .Font.Name = "Calibri"
        End With

        'Save and close the Word doc.
        'With wdDoc
        '    .Save
        '    .Close
        'End With

        'Quit Word.
        'wdApp.Quit

    '++++++++++++++++++++++++++++++++++++++++++++++++

        'Null out your variables.
        'Set wdbmRange = Nothing
        'Set wdDoc = Nothing
        'Set wdApp = Nothing

        'Clear out the clipboard, and turn screen updating back on.
        'With Application
        '    .CutCopyMode = False
        '    .ScreenUpdating = True
        'End With

    '+++++++++++++++++++++++++++++++++++++++++++++++++++

        'MsgBox "The report has successfully been " & vbNewLine & _
               "transferred to " & stWordReport, vbInformation

        
    End Sub


    2º - No meu Access, tenho o módulo abaixo que chama essa macro do excel e faz todos os outros preenchimentos no Word:

    Código:
    Public Function GeraDocumento()
    Dim Nome_Arquivo As String
    Dim msg As String

    On Error GoTo TrataErro
    'Define o nome que será salvo o Word
    Nome_Arquivo = "Numero da proposta" & " - " & [Forms]![frm_principal]![Empreendimento] & " - " & [Forms]![frm_Clientes]![Cliente1] & " - " & [Forms]![frm_principal]![Num_Aditivo]
    TrataErro:
        If Err.Number = 94 Then
            msg = MsgBox("Não foi especificado o nome do arquivo na aba de ""Condições Gerais""", vbInformation, "Atenção")
            Exit Function
        Else
        End If

    'verifica se já existe um arquivo com o nome especificado na pasta output
    'If Len(Dir(CurrentProject.Path & "\Output\" & Nome_Arquivo & ".docx", vbDirectory)) = 0 Then
                'abre os formulario com as mensagens da etapa
                DoCmd.OpenForm "frm_geração"
                
                'abre o formulario de fiadores para pegar as informações de preenchimento
                DoCmd.OpenForm "frm_Clientes"
                Forms!frm_Clientes.Visible = False
                DoCmd.OpenForm "frm_Fiadores"
                Forms!frm_Fiadores.Visible = False
                
                'chama o módulo que cria a pasta e baixa o template
                Call abrirtemplate
                    
                '========================================
                '---------INÍCIO: GERA O TERMO-----------
                
                Dim wdApl As Object
                Dim strLocal As String
                Set wdApl = CreateObject("Word.Application")
                Dim FicheiroPDF As String
                          
                'Abre o template
                'wdApl.Documents.Open FileName:=CurrentProject.Path & "\Template_Aditivo.docm" ',passwordDocument:="SenhaDoDocumento"
                wdApl.Documents.Open FileName:=CurrentProject.Path & "\PastaTemporaria - " & UsuarioRede() & "\Template_Aditivo.docm", ReadOnly:=True ',passwordDocument:="SenhaDoDocumento"
                    
                    With wdApl
                                
         Dim xlsApp As Excel.Application
    Dim wbBook As Excel.Workbook
    Dim wsSheet As Worksheet
    Dim rnReport As Range
    Set wbBook = Workbooks.Open(CurrentProject.Path & "\SEL_Report.xlsm")
    Set xlsApp = wbBook.Parent

    wdApl.Visible = False
                                
           xlsApp.Run "PreencheTabela"
        
    xlsApp.Application.Quit
        
        '.ActiveDocument.Bookmarks("Teste_Tabela").Select: .PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
                                                           Placement:=wdInLine, DisplayAsIcon:=False
                    
                    
                    
                    'Posiciona o cursor no INDICADOR e preenche com os dados do formulário
                    .ActiveDocument.Bookmarks("Num_Aditivo").Select: .Selection.Text = Nz([Forms]![frm_principal]![Num_Aditivo])
                    .ActiveDocument.Bookmarks("Num_Aditivo_Final").Select: .Selection.Text = Nz([Forms]![frm_principal]![Num_Aditivo_Final])
                    .ActiveDocument.Bookmarks("Cliente").Select: .Selection.Text = Nz([Forms]![frm_principal]![Clientes])
                    .ActiveDocument.Bookmarks("Fiador1").Select: .Selection.Text = Nz([Forms]![frm_principal]![Fiadores])
                    .ActiveDocument.Bookmarks("Hipotecante").Select: .Selection.Text = Nz([Forms]![frm_principal]![Hipotecante])
                    .ActiveDocument.Bookmarks("Contrato").Select: .Selection.Text = Nz([Forms]![frm_principal]![QdResumo_contrato])
                    .ActiveDocument.Bookmarks("Garantias").Select: .Selection.Text = Nz([Forms]![frm_principal]![Garantias])
                    .ActiveDocument.Bookmarks("Prazos_Financiamento").Select: .Selection.Text = Nz([Forms]![frm_principal]![prazos_aditivo])
                    .ActiveDocument.Bookmarks("Taxa_Anual").Select: .Selection.Text = Nz([Forms]![frm_principal]![Taxa_Anual])
                    .ActiveDocument.Bookmarks("Taxa_Mensal").Select: .Selection.Text = Nz([Forms]![frm_principal]![Taxa_Mensal])
                    .ActiveDocument.Bookmarks("Taxa_Efetiva_Anual").Select: .Selection.Text = Nz([Forms]![frm_principal]![Taxa_Efetiva_Anual])
                    .ActiveDocument.Bookmarks("Prazos_aditivo").Select: .Selection.Text = Nz([Forms]![frm_principal]![Prazo_aditivo])
                    .ActiveDocument.Bookmarks("Valor_Tarifa_Aditamento").Select: .Selection.Text = Nz([Forms]![frm_principal]![Valor_Tarifa_Aditamento])
                    .ActiveDocument.Bookmarks("Do_Contrato").Select: .Selection.Text = Nz([Forms]![frm_principal]![Cláusulas_Aditivos])
                    wdApl.Selection.Range.Font.Bold = False
                    wdApl.Selection.Range.Font.Underline = False
                    .ActiveDocument.Bookmarks("Condições_Gerais").Select: .Selection.Text = Nz([Forms]![frm_principal]![CONDIÇÕES])
                    .ActiveDocument.Bookmarks("Data").Select: .Selection.Text = Nz(Format([Forms]![frm_principal]![Data_Assinatura], "dd") & " de " & Format(Now(), "Mmmm") & " de " & Format(Now(), "yyyy"))
                    .ActiveDocument.Bookmarks("Ass_Credor").Select: .Selection.Text = Nz([Forms]![frm_principal]![Ass_Cliente])
                    '.ActiveDocument.Bookmarks("Ass_Hipotecante").Select: .Selection.Text = Nz([Forms]![frm_principal]![Ass_Hipotecante])
                    .ActiveDocument.Bookmarks("Ass_Fiador").Select: .Selection.Text = Nz([Forms]![frm_principal]![Ass_Fiador])
                    wdApl.Selection.Range.Font.Bold = False
                    wdApl.Selection.Range.Font.Underline = False
                                                      
                '===============INICIA NEGRITO CLIENTE/HIPOTECANTE E FIADORES================
                '----------------------------------------------------------------------------
                    With wdApl.Selection.Find
                    .ClearFormatting
                    If [Forms]![frm_Clientes]![Cliente1] <> "" Then
                    .Text = [Forms]![frm_Clientes]![Cliente1] & ","
                    .Replacement.Font.Bold = True
                    .Replacement.Font.Italic = False
                    .Replacement.Font.Underline = False
                    .Replacement.Text = [Forms]![frm_Clientes]![Cliente1] & ","
                    .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
                    End If
                    
                    If [Forms]![frm_Clientes]![Cliente2] <> "" Then
                    .Text = [Forms]![frm_Clientes]![Cliente2] & ","
                    .Replacement.Font.Bold = True
                    .Replacement.Font.Italic = False
                    .Replacement.Font.Underline = False
                    .Replacement.Text = [Forms]![frm_Clientes]![Cliente2] & ","
                    .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
                    End If
                    
                    If [Forms]![frm_Clientes]![Cliente3] <> "" Then
                    .Text = [Forms]![frm_Clientes]![Cliente3] & ","
                    .Replacement.Font.Bold = True
                    .Replacement.Font.Italic = False
                    .Replacement.Font.Underline = False
                    .Replacement.Text = [Forms]![frm_Clientes]![Cliente3] & ","
                    .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
                    End If
                    
                    If [Forms]![frm_Fiadores]![Fiador1] <> "" Then
                    .Text = [Forms]![frm_Fiadores]![Fiador1] & ","
                    .Replacement.Font.Bold = True
                    .Replacement.Font.Italic = False
                    .Replacement.Font.Underline = False
                    .Replacement.Text = [Forms]![frm_Fiadores]![Fiador1] & ","
                    .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
                    End If
                    
                    End With
                '===============INICIA NEGRITO CLIENTE/HIPOTECANTE E FIADORES================
                '----------------------------------------------------------------------------
                    
                    
                'mensagens da etapas de confecção do documento
                Forms.frm_geração.msg1.Visible = False
                Forms.frm_geração.msg2.Visible = True
                Forms.frm_geração.Caixa719.Visible = True
                                      
                'chama a macro no word que coloca os negritos
                wdApl.Run "Negritos"
                
                'chama a macro no word que coloca os negritos
                wdApl.Run "numeracaoclausulas"
                                      
                'Define o local que será salvo o Word
                strLocal = CurrentProject.Path & "\Output\" & Nome_Arquivo & ".docx"
                'Salva o Word - Se não quiser salvar o word, basta comentar ou excluir essa linha
                .ActiveDocument.SaveAs strLocal, FileFormat:=wdFormatDocumentDefault ' , Password:="123"
                
                Set wdApl = .ActiveDocument
                
                'mensagens da etapas de confecção do documento
                Forms.frm_geração.msg2.Visible = False
                Forms.frm_geração.msg3.Visible = True
                Forms.frm_geração.Caixa720.Visible = True
                
                
                'Define o local e nome que será salvo o PDF
                FicheiroPDF = CurrentProject.Path & "\Output\" & Nome_Arquivo & ".pdf"
                'Código para salvar o PDF
                wdApl.ExportAsFixedFormat OutputFileName:=FicheiroPDF, ExportFormat:= _
                wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
                Item:=wdExportDocumentContent, IncludeDocProps:=True
                                                  
                'Fecha o documento
                .ActiveDocument.Close
                'Fecha o Word
                wdApl.Quit
                End With
                'Limpa a memória
                Set wdApl = Nothing
                
                '---------FIM: GERA O TERMO-----------
                '========================================
                
                'mensagens da etapas de confecção do documento
                Forms.frm_geração.msg3.Visible = False
                Forms.frm_geração.msg4.Visible = True
                Forms.frm_geração.Caixa721.Visible = True
                Forms.frm_geração.btFechar.Visible = True
                
                'Fecha o fomulario de fiadores
                DoCmd.Close acForm, "frm_Fiadores"
                DoCmd.Close acForm, "frm_Clientes"
                
                'apaga todos os ficheiros da pasta temporaria
                  Kill CurrentProject.Path & "\PastaTemporaria - " & UsuarioRede() & "\" & "*.docm"
                'depois apaga a pasta temporaria
                  RmDir CurrentProject.Path & "\PastaTemporaria - " & UsuarioRede() & "\"

    'Else
    '    msg = MsgBox("Já existe um arquivo salvo com esse nome." & vbCrLf & vbCrLf & "Verificar na pasta ""\Output\"" se trata-se de uma duplicidade ou " _
        & "altere o nome do arquivo na aba de " & """Condições Gerais""!", vbExclamation + vbOKOnly + vbDefaultButton2, "Atenção!")
    'End If

    End Function


    Aqui está o meu problema, se rodo a macro do excel na mão, ela funciona perfeitamente.
    Quando chamo a macro pelo Access, ele gera o documento do Word normalmente, mas acontece que a tabela não está salva.



    Se alguém souber algum outro modo mais fácil, seria melhor ainda!!!


    Alguém consegue me ajudar?

    Desde já, agradeço!

      Data/hora atual: 18/11/2018, 19:11