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


    Construir uma tabela no Word através do VBA a partir de dados de uma tabela Access

    avatar
    danrob
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Anónimo
    Mensagens : 1
    Registrado : 30/08/2013

    Construir uma tabela no Word através do VBA a partir de dados de uma tabela Access    Empty Construir uma tabela no Word através do VBA a partir de dados de uma tabela Access

    Mensagem  danrob em 18/12/2018, 18:10

    Prezados boa tarde!

    Tenho um projeto no qual preciso construir um documento em formato Word a partir de dados de uma tabela do Access.
    A idéia seria abrir um documento Word template, colar algumas informações em formato texto (já realizo isso) e na sequência montar uma tabela com o número de colunas pré-definidas, mas as linhas conforme for a necessidade de um contador.
    Costumo montar e-mails desta forma, mas quando tento fazer a mesma coisa para o Word, ao invés de colar a informação está colando o próprio código.
    Abaixo segue o código:

    Private Sub GerarRel()

       Dim oWord As Word.Application
       Dim oDoc As Word.Document
       Dim oTable As Word.Table
       Dim oPara1 As Word.Paragraph, oPara2 As Word.Paragraph
       Dim oPara3 As Word.Paragraph, oPara4 As Word.Paragraph
       Dim oRng As Word.Range
       Dim oShape As Word.InlineShape
       Dim oChart As Object
       Dim Pos As Double
       Dim OutApp As Object
       Dim OutMail As Object
       Dim UsuarioRede As String
       Dim GetUserN
       Dim ObjNetwork
       Const msoSendToBack As Long = 0
       Dim ComboICVM As String
       Dim ComboEmpresa As String
       Dim Titulo As String
       Dim Consist As Integer
       Dim SqlIndice As String
       Dim SqlTexto As String
       Dim SqlCorreios As String
       Dim db As Database
       Dim Tab_Fun_Gestor, Tab_Dados, Tab_Pri_Nome_Gestor, Tab_Correios As Recordset
       Dim cnnSist As New ADODB.Connection
       Dim rsSist As ADODB.Recordset
       
     
       Set ObjNetwork = CreateObject("WScript.Network")
       GetUserN = ObjNetwork.UserName
       UsuarioRede = GetUserN
       
       pasta = CurrentProject.Path
       Set db = CurrentDb()
       
       'ComboDir = Me.CombDiretoria
       
       If IsNull(Me.CombICVM) Then
           On Error GoTo Error1
           MsgBox "Selecione o 'Relatório' que deseja gerar e refaça a operação.", vbCritical, "Atenção!!!"
           
           ElseIf Not IsNull(Me.CombICVM) Then
           ComboICVM = Me.CombICVM
       
    GoTo sairIf

    Error1:

    End If

    sairIf:


       If IsNull(Me.CombEmpresa) Then
           On Error GoTo Error2
           MsgBox "Selecione a 'Empresa' vinculada ao relatório e refaça a operação.", vbCritical, "Atenção!!!"
           
           
           ElseIf Not IsNull(Me.CombEmpresa) Then
           ComboEmpresa = Me.CombEmpresa
           
    GoTo sairIf2

    Error2:

    End If
    Exit Sub
    sairIf2:

    '    Call Image_1(ComboICVM, ComboEmpresa)
    ' CABEÇALHO

       fonte10 = "  "
       fonte12v = "  "
       fonteb = " "
       fonteb2 = " "
       fontec = " "
       fonted = " "
       fontej = " "
           
           
           Set cnnSist = CurrentProject.Connection
           Set rsSist = New ADODB.Recordset
           
           rsSist.CursorType = adOpenKeyset
           rsSist.LockType = adLockOptimistic
               
           'Start Word and open the document template.
           Set oWord = CreateObject("Word.Application")
           oWord.Visible = True
           oWord.Documents.Open FileName:=CurrentProject.Path & "\template.docx"
               
           SqlIndice = "SELECT TB_RELAT_ICVM.ICVM, TB_RELAT_ICVM.Empresas, TB_RELAT_ICVM.Endereco, TB_RELAT_ICVM.Indice " _
           & "FROM TB_RELAT_ICVM " _
           & "GROUP BY TB_RELAT_ICVM.ICVM, TB_RELAT_ICVM.Empresas, TB_RELAT_ICVM.Endereco, TB_RELAT_ICVM.Indice " _
           & "HAVING (((TB_RELAT_ICVM.ICVM)=" & "'" & ComboICVM & "'" & ") AND ((TB_RELAT_ICVM.Empresas)=" & "'" & ComboEmpresa & "'" & "))"

           
           Set oDoc = oWord.ActiveDocument
           Set oPara1 = oDoc.Content.Paragraphs.Add
           oPara1.Range.Font.Name = "Calibri"
           oPara1.Range.Font.Size = 11
           oPara1.Range.Font.Color = wdColorBlack
           oPara1.Range.Font.Bold = True
           oPara1.Range.Text = "SUMÁRIO"
           oPara1.Format.SpaceAfter = 0    '24 pt spacing after paragraph.
           oPara1.Range.InsertParagraphAfter
           
           Set Tab_Indice = db.OpenRecordset(SqlIndice)
                   
           qtd_Tab_Indice = Tab_Indice.RecordCount
           

           If qtd_Tab_Indice > 0 Then
           
           While Not Tab_Indice.EOF
           
           
           Set oDoc = oWord.ActiveDocument
           'Insert a paragraph at the beginning of the document.
       
       
           Set oPara1 = oDoc.Content.Paragraphs.Add
           oPara1.Range.Font.Name = "Calibri"
           oPara1.Range.Font.Size = 11
           oPara1.Range.Font.Color = wdColorBlack
           oPara1.Range.Font.Bold = True
           oPara1.Range.Text = Tab_Indice.Fields(2) & " " & Tab_Indice.Fields(3)
           oPara1.Format.SpaceAfter = 0    '24 pt spacing after paragraph.
           oPara1.Range.InsertParagraphAfter
       
           
           Tab_Indice.MoveNext
               
           Wend
           
           ElseIf qtd_Tab_Indice = 0 Then
           
           
           End If
           
           
           Set oDoc = oWord.ActiveDocument
           
           
           Set objSelection = oWord.Selection
           objSelection.EndKey Unit:=wdStory
           objSelection.InsertNewPage
    '        objSelection.InsertBreak (wdSectionBreakNextPage)
    '        objSelection.TypeText "This is page 1"
    '        objSelection.InsertBreak (wdPageBreak)
    '        objSelection.TypeText "This is page 2"
           
           
           

           SqlTexto = "SELECT TB_RELAT_ICVM.ICVM, TB_RELAT_ICVM.Empresas, TB_RELAT_ICVM.Endereco, TB_RELAT_ICVM.Indice, TB_RELAT_ICVM.Linha1, " _
           & "TB_RELAT_ICVM.Figura1, TB_RELAT_ICVM.Linha2, TB_RELAT_ICVM.Figura2, TB_RELAT_ICVM.Linha3, TB_RELAT_ICVM.Figura3, TB_RELAT_ICVM.Linha4, " _
           & "TB_RELAT_ICVM.Figura4, TB_RELAT_ICVM.Linha5, TB_RELAT_ICVM.Figura5, TB_RELAT_ICVM.Linha6, TB_RELAT_ICVM.Figura6, TB_RELAT_ICVM.Linha7, " _
           & "TB_RELAT_ICVM.Figura7, TB_RELAT_ICVM.Linha8, TB_RELAT_ICVM.Figura8, TB_RELAT_ICVM.Linha9, TB_RELAT_ICVM.Figura9, TB_RELAT_ICVM.Linha10, TB_RELAT_ICVM.Figura10 " _
           & "FROM TB_RELAT_ICVM " _
           & "WHERE (((TB_RELAT_ICVM.ICVM)=" & "'" & ComboICVM & "'" & ") AND ((TB_RELAT_ICVM.Empresas)=" & "'" & ComboEmpresa & "'" & "))"
           
         
           
           Set Tab_texto = db.OpenRecordset(SqlTexto)
                   
           qtd_Tab_Texto = Tab_texto.RecordCount
           
    '        sPicture = Image_1(ComboICVM, ComboEmpresa)
           
           
           If qtd_Tab_Texto > 0 Then
           
           While Not Tab_texto.EOF
           
                   
           Set oDoc = oWord.ActiveDocument
           'Insert a paragraph at the beginning of the document.
           Set oPara1 = oDoc.Content.Paragraphs.Add

           oPara1.Range.Font.Name = "Calibri"
           oPara1.Range.Font.Size = 11
           oPara1.Range.Font.Color = wdColorBlack
           oPara1.Range.Font.Bold = True
           oPara1.Range.Text = Tab_texto![Endereco] & " " & Tab_texto![Indice]
           
           oPara1.Range.InsertParagraphAfter
           oPara1.Range.InsertParagraphAfter
           
           oPara1.Range.Font.Bold = False
           
           If Not IsNull(Tab_texto![Linha1]) Then
               oPara1.Range.Font.Name = "Calibri"
               oPara1.Range.Font.Size = 11
               oPara1.Range.Font.Color = wdColorBlack
               oPara1.Range.Font.Bold = False
               oPara1.Range.Text = Tab_texto![Linha1]
               ElseIf IsNull(Tab_texto![Linha1]) Then
               oPara1.Range.InsertParagraphAfter
           End If
           
           If Not IsNull(Tab_texto![Figura1]) Then
               oPara1.Range.InsertParagraphAfter
               oPara1.Range.InlineShapes.AddPicture FileName:=Tab_texto![Figura1], LinkToFile:=False, SaveWithDocument:=True
               ElseIf IsNull(Tab_texto![Figura1]) Then
               
           End If
           
           If Not IsNull(Tab_texto![Linha2]) Then
               oPara1.Range.InsertParagraphAfter
               oPara1.Range.Font.Name = "Calibri"
               oPara1.Range.Font.Size = 11
               oPara1.Range.Font.Color = wdColorBlack
               oPara1.Range.Font.Bold = False
               oPara1.Range.Text = Tab_texto![Linha2]
               ElseIf IsNull(Tab_texto![Linha2]) Then
               oPara1.Range.InsertParagraphAfter
           End If
           
           Tab_texto.MoveNext
               
           Wend


    .... daqui para baixo que preciso construir uma tabela a partir dos dados do access...

    Espero que tenham compreendido minha necessidade.

    Alguém consegue me ajudar?

    Obrigado!

    IvanJr.
    IvanJr.
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 674
    Registrado : 22/11/2016

    Construir uma tabela no Word através do VBA a partir de dados de uma tabela Access    Empty Re: Construir uma tabela no Word através do VBA a partir de dados de uma tabela Access

    Mensagem  IvanJr. em 18/12/2018, 21:16

    No tópico do link abaixo há em anexo exemplo que faz o que precisa na mensagem nº 24 do colega FabioGo. Veja
    http://www.maximoaccess.com/t7607-resolvidoexportacao-de-access-para-word

    No link mais abaixo um artigo que trata do assun
    usandoaccess.com.br/dicas/preencher-tabela-word-com-access.asp?id=1&idlista=239


    .................................................................................
    Positive as mensagens que achar útil clicando no '+' no canto superior direito delas.
    Sempre tente entender o código, não somente copie e cole.

      Data/hora atual: 23/7/2019, 06:32