Access data to WORD

[wverweij]

Hi,

Maybe already solved or asked before but i'm desperate.

I'm strugling with transferring data from access to ä word template.

1. transferring single data fields works okay, with bookmarks etc.

2. transferring multiple records (e.g. orderlines) to a WORD template fails. The # of multiple records are variable. So could not be defined upfront how may records i have to transfer.

I tried to transfer the data in a word table both with bookmarks and with merge fields. The result was that all data was placed in de first cell of the table in WORD.

Please give me some help. Setting up de WORD template combining with the VBA code.

See VBA code:

Private Sub Knop17_Click()
On Error GoTo Err_knop17_Click

Dim sreportname As String
Dim scurrentdir As String
Dim stemplatedir As String
Dim stemplatename As String
Dim ObjWord As Word.Application
Dim ObjDoc As Word.Document
Dim bm As Object

scurrentdir = "\\mijnasp\ijslandtours\data\data2\ijsland tours\reisbescheiden\accommodatielijsten\"
stemplatedir = scurrentdir + "template\"
sreportname = scurrentdir & Me.rtBoekingID & " - " & Me.bkPartyOmschrijving & " - routebeschrijving.doc"
stemplatename = stemplatedir & "Route-template - kopie.dotx"

'check if template still existst

'check if reportname already exists

'open word
On Error Resume Next
' check if word is already running
Set ObjWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set ObjWord = CreateObject("Word.Application")
End If
On Error GoTo Err_knop17_Click

' open template as a new doc
Set ObjDoc = ObjWord.Documents.Add(Template:=stemplatename, NewTemplate:=False)

'fill data in bookmarks
ObjWord.Selection.Goto What:=wdGoToBookmark, Name:="Boekingnr"
ObjWord.Selection.TypeText Text:=CStr(rtBoekingID)

ObjWord.Selection.Goto What:=wdGoToBookmark, Name:="Reizigers"
ObjWord.Selection.TypeText Text:=Trim(bkPartyOmschrijving)

ObjWord.Selection.Goto What:=wdGoToBookmark, Name:="Reis"
ObjWord.Selection.TypeText Text:=Trim(bkReisnaam)

ObjWord.Selection.Goto What:=wdGoToBookmark, Name:="Aantal"
ObjWord.Selection.TypeText Text:=CStr(bkPAX)

ObjWord.Selection.Goto What:=wdGoToBookmark, Name:="Begdatum"
ObjWord.Selection.TypeText Text:=CStr(bkBegindatum)

ObjWord.Selection.Goto What:=wdGoToBookmark, Name:="Einddatum"
ObjWord.Selection.TypeText Text:=CStr(bkEinddatum)

'-------------------- repeating block voor routebeschrijvingen

'1. run query voor verzamelen alle records

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strRecords As String
Dim sqlstr As String

sqlstr = "SELECT tblRoute.rtBoekingID, tblKlanten.klBedrijfsnaam, tblReissegmenten.rsNaam, tblReissegmenten.rsCode, tblBoekingssegmenten.bsAankomstdatum, tblBoekingssegmenten.bsVertrekdatum, tblRoute.rtRoute, tblBoekingen.bkBegindatum, tblBoekingen.bkEinddatum, tblBoekingen.bkReisnaam, tblBoekingen.bkPAX, tblBoekingen.bkPartyOmschrijving, tblReissegmenten.rsAdres1, tblReissegmenten.rsTelnr, tblReissegmenten.rsPlaats FROM ((tblRoute INNER JOIN (tblReissegmenten INNER JOIN tblBoekingssegmenten ON tblReissegmenten.rsReissegmentID = tblBoekingssegmenten.bsReissegmentID) ON tblRoute.rtBoekingssegmentID = tblBoekingssegmenten.bsBoekingssegmentID) INNER JOIN tblBoekingen ON tblRoute.rtBoekingID = tblBoekingen.bkBoekingID) INNER JOIN tblKlanten ON tblBoekingen.bkKlantID = tblKlanten.klKlantID WHERE (((tblRoute.rtBoekingID)=" & rtBoekingID & ") AND ((tblBoekingssegmenten.bsVoucher)=False))"
Set db = CurrentDb()
Set rs = db.OpenRecordset(sqlstr, dbOpenDynaset)

If rs.RecordCount > 0 Then

'loop thru all the records
While Not rs.EOF
strRecords = strRecords & rs.Fields("rsNaam").Value & Chr(9)
strRecords = strRecords & rs.Fields("rsTelnr").Value & Chr(9)
strRecords = strRecords & CStr(rs.Fields("bsAankomstdatum").Value) & Chr(9)
strRecords = strRecords & rs.Fields("rsAdres1").Value & Chr(9)
strRecords = strRecords & CStr(rs.Fields("bsVertrekdatum").Value) & Chr(9)
strRecords = strRecords & rs.Fields("rsPlaats").Value & Chr(9) & Chr(9)
strRecords = strRecords & rs.Fields("rtRoute").Value & vbCrLf
rs.MoveNext
Wend
rs.Close
Set rs = Nothing

'-----------------------------------

ObjDoc.Bookmarks("StartBlock_Route").Select
ObjWord.Selection.Text = strRecords & ""

'--------------------

End If

'Update fields in Word document and activate it
ObjWord.Visible = True
ObjWord.Selection.WholeStory
ObjWord.Selection.Fields.Update
ObjWord.ActiveDocument.SaveAs2 sreportname
ObjWord.Activate
ObjWord.Selection.EndKey Unit:=wdStory
ObjWord.ActiveWindow.WindowState = 0

Exit_knop17_Click:
Set ObjWord = Nothing
'ObjDoc.Close True
Set ObjDoc = Nothing
Exit Sub

Err_knop17_Click:
MsgBox Err.Description
Resume Exit_knop17_Click

End Sub


Regards and thanks,

Wouter

 

[Pat Hartman]

What I've done to handle multiple row subsets is to build the string in VBA by looping through the child records and concatenating the headers and columns with tabs and using crlf at the end of each line. Once the data is assembled, I post it to a bookmark and while it is still selected, convert it to a table. Then I either specify a standard table format if one is appropriate or I format it myself.

 

[wverweij]

Hi Pat,

I thought I did it in de VBA code as you described. Hope you can validate.

1. set up the sql statement
2. gather all the data inclusive tabs en crlf (i hope i did okay)
3. select the table
4. transfer the data to the table

The output is that all multiple records placed in the first cell of the selected table.

maybe could you give me a working example?

thanks

regards


Wouter Verweij

 

[Pat Hartman]

It is hard to pull out only the relevant code but this should get you going. The app I pulled this from creates thousands of different letters and there are a bunch of different "table" subsets made from the same basic data so the code makes all of them at once.

FillDepFields:

    ' Dependent fields are fixed because they are all done as lists of some sort
    ' and represent multiple records
    
    Dim DepNameList As String
    Dim DepNameString As String
    Dim DepNameTable As String
    Dim DepNameTableAmnestyPhase As String
    Dim DepNameTableResults As String
    Dim DepNameTableEligibility As String
    Dim DepWithPending As String
    Dim DepWithPendingAndReason As String
    Dim DepWithReason As String
    Dim DepWithDOBAndReason As String
    Dim DepWithDOB As String
    Dim DepWithDOBEligibility As String
    
    Dim DepApproved As String
    Dim DepDenied As String
    Dim DepEligible As String
    Dim DepIneligible As String
    Dim DepPended As String
    Dim DepRevDesc As String
    
    DepNameList = ""
    DepNameString = ""
    DepNameTable = "FIRST" & vbTab & "LAST" & vbTab & "RELATIONSHIP" & vbCrLf
''''    DepNameTableAmnestyPhase = "First" & vbTab & "Last" & vbTab & "Relationship" & vbTab & "Eligible" & vbTab & "Amnesty Disenrolled" & vbCrLf
    DepNameTableAmnestyPhase = "FIRST" & vbTab & "LAST" & vbTab & "RELATIONSHIP" & vbTab & "ELIGIBLE" & vbTab & "INELIGIBLE" & vbCrLf
    DepNameTableEligibility = "FIRST" & vbTab & "LAST" & vbTab & "RELATIONSHIP" & vbTab & "ELIGIBLE" & vbTab & "INELIGIBLE" & vbCrLf
    DepNameTableResults = "FIRST" & vbTab & "LAST" & vbTab & "RELATIONSHIP" & vbTab & "GRANTED" & vbTab & "DENIED" & vbTab
    DepNameTableResults = DepNameTableResults & "REQUESTED DATE" & vbTab & "DECISION DATE" & vbCrLf
    DepWithPending = "FIRST" & vbTab & "LAST" & vbTab & "RELATIONSHIP" & vbTab & "ELIGIBLE" & vbTab & "PENDING" & vbTab & "INELIGIBLE" & vbCrLf
    DepWithPendingAndReason = "FIRST" & vbTab & "LAST" & vbTab & "RELATIONSHIP" & vbTab & "ELIGIBLE" & vbTab & "PENDING" & vbTab & "INELIGIBLE"
    DepWithPendingAndReason = DepWithPendingAndReason & vbTab & "REASON" & vbCrLf
    DepWithReason = "FIRST" & vbTab & "LAST" & vbTab & "Relationship" & vbTab & "ELIGIBLE" & vbTab & "INELIGIBLE" & vbTab & "REASON" & vbCrLf
    DepWithDOBAndReason = "FIRST" & vbTab & "LAST" & vbTab & "DOB" & vbTab & "RELATIONSHIP" & vbTab & "ELIGIBLE" & vbTab & "INELIGIBLE" & vbTab & "REASON" & vbCrLf
    DepWithDOB = "FIRST" & vbTab & "LAST" & vbTab & "DOB" & vbTab & "RELATIONSHIP" & vbCrLf
    DepWithDOBEligibility = "FIRST" & vbTab & "LAST" & vbTab & "DOB" & vbTab & "RELATIONSHIP" & vbTab & "ELIGIBLE" & vbTab & "INELIGIBLE" & vbCrLf
    
    Do While rsData.EOF = False
        HasDependents = True        'used to allow printing to be cancelled if no dependents are found
        DepNameList = DepNameList & rsData!FirstName & " " & rsData!LastName & vbCrLf
        DepNameString = DepNameString & rsData!FirstName & " " & rsData!LastName & "; "
        DepNameTable = DepNameTable & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbCrLf
        Select Case rsData!AppealDecisionCD
            Case 1  'granted
                DepApproved = "    X   "
                DepDenied = "      "
            Case 2  'denied
                DepApproved = "       "
                DepDenied = "    X   "
            Case Else
                DepApproved = "      "
                DepDenied = "      "
        End Select

 
        Select Case rsData!DepEligibleCD
            Case 1  'eligible
                DepEligible = "    X   "
                DepIneligible = "      "
                DepPended = "      "
            Case 2  'ineligible
                DepEligible = "       "
                DepIneligible = "    X   "
                DepPended = "      "
            Case 3  'pending
                DepEligible = "       "
                DepIneligible = "       "
                DepPended = "    X   "
            Case Else
                DepEligible = "     "
                DepIneligible = "    "
                DepPended = "      "
        End Select

'''            Select Case rsData!DisenrollmentRequestedYN
'''                Case True   'requested
'''                    DepApproved = "       "
'''                    DepDenied = "    X   "
'''                Case False  ' not requested
'''                    DepApproved = "    X   "
'''                    DepDenied = "      "
'''                Case Else   'not requested
'''                    DepApproved = "     "
'''                    DepDenied = "    "
'''            End Select
                
                
        DepNameTableAmnestyPhase = DepNameTableAmnestyPhase & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepIneligible & vbCrLf
        DepNameTableResults = DepNameTableResults & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbTab & DepApproved & vbTab & DepDenied & vbTab
        DepNameTableResults = DepNameTableResults & rsData!AppealReqDT & vbTab & rsData!AppealDecisionDT & vbCrLf
        DepNameTableEligibility = DepNameTableEligibility & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepIneligible & vbCrLf
        DepWithPending = DepWithPending & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepPended & vbTab & DepIneligible & vbCrLf
        DepWithPendingAndReason = DepWithPendingAndReason & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepPended & vbTab & DepIneligible & vbTab & rsData!DisenrollReason & vbCrLf
        DepWithReason = DepWithReason & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepIneligible & vbTab & rsData!DisenrollReason & vbCrLf
        DepWithDOBAndReason = DepWithDOBAndReason & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepDOB & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepIneligible & vbTab & rsData!DisenrollReason & vbCrLf
        DepWithDOB = DepWithDOB & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepDOB & vbTab & rsData!DepType & vbCrLf
        DepWithDOBEligibility = DepWithDOBEligibility & rsData!FirstName & vbTab & rsData!LastName & vbTab & rsData!DepDOB & vbTab & rsData!DepType & vbTab & DepEligible & vbTab & DepIneligible & vbCrLf

'        If IsNull(rsData!Comments) Then
'               ' MsgBox "Required field - " & rsDAO!FieldDescription & "  -  is missing", vbOKOnly+vbInformation
'            WordDoc.FormFields("DepComments").Result = ""
'        Else
'            WordDoc.Bookmarks("DepComments").Range.Fields(1).Result.Text = rsData!Comments
'        End If
        
    rsData.MoveNext
    Loop
    If HasDependents = False Then
        Return
    End If
    DepNameString = Left(DepNameString, Len(DepNameString) - 2) 'remove trailing ;
    
    WordDoc.Bookmarks("DepNameList").Range.Text = DepNameList
    WordDoc.Bookmarks("DepNameList2").Range.Text = DepNameList
    WordDoc.Bookmarks("DepNameString").Range.Text = DepNameString
    WordDoc.Bookmarks("DepNameString2").Range.Text = DepNameString
    If DepNameTable <> "" Then
        DepNameTable = Left(DepNameTable, Len(DepNameTable) - 1)
        Call FinishTable("DepNameTable", DepNameTable)
    End If
    If DepNameTableResults <> "" Then
        DepNameTableResults = Left(DepNameTableResults, Len(DepNameTableResults) - 1)
        Call FinishTable("DepNameTableResults", DepNameTableResults)
    End If
    If DepNameTableAmnestyPhase <> "" Then
        DepNameTableAmnestyPhase = Left(DepNameTableAmnestyPhase, Len(DepNameTableAmnestyPhase) - 1)
        Call FinishTable("DepNameTableAmnestyPhase", DepNameTableAmnestyPhase)
    End If
    If DepNameTableEligibility <> "" Then
        DepNameTableEligibility = Left(DepNameTableEligibility, Len(DepNameTableEligibility) - 1)
        Call FinishTable("DepNameTableEligibility", DepNameTableEligibility)
    End If
    If DepWithPending <> "" Then
        DepWithPending = Left(DepWithPending, Len(DepWithPending) - 1)
        Call FinishTable("DepWithPending", DepWithPending)
    End If
    If DepWithPendingAndReason <> "" Then
        DepWithPendingAndReason = Left(DepWithPendingAndReason, Len(DepWithPendingAndReason) - 1)
        Call FinishTable("DepWithPendingAndReason", DepWithPendingAndReason)
    End If
    If DepWithReason <> "" Then
        DepWithReason = Left(DepWithReason, Len(DepWithReason) - 1)
        Call FinishTable("DepWithReason", DepWithReason)
    End If
    If DepWithDOBAndReason <> "" Then
        DepWithDOBAndReason = Left(DepWithDOBAndReason, Len(DepWithDOBAndReason) - 1)
        Call FinishTable("DepWithDOBAndReason", DepWithDOBAndReason)
    End If
    If DepWithDOB <> "" Then
        DepWithDOB = Left(DepWithDOB, Len(DepWithDOB) - 1)
        Call FinishTable("DepWithDOB", DepWithDOB)
    End If
    If DepWithDOBEligibility <> "" Then
        DepWithDOBEligibility = Left(DepWithDOBEligibility, Len(DepWithDOBEligibility) - 1)
        Call FinishTable("DepWithDOBEligibility", DepWithDOBEligibility)
    End If
Return


Public Sub FinishTable(bkmk As String, strTable As String)
    
    On Error GoTo Proc_Err

   '''' WordApp.Visible = True  'uncomment for testing
    
    Call InsertTextAtBookMark(bkmk, strTable)
    Set objTable = WordApp.Selection.ConvertToTable(Separator:=vbTab)
    objTable.AutoFormat Format:=wdTableFormatProfessional, applyshading:=False, applyHeadingrows:=True, AutoFit:=True
    objTable.AutoFitBehavior (wdAutoFitWindow)
    WordApp.Selection.MoveRight unit:=wdCell
    WordApp.Selection.MoveRight unit:=wdCell
    WordApp.Selection.SelectRow
    WordApp.Selection.Font.Bold = wdToggle
    WordApp.Selection.Shading.Texture = wdTextureNone
    WordApp.Selection.Shading.ForegroundPatternColor = wdColorAutomatic
'    WordApp.Selection.Shading.BackgroundPatternColor = -603923969 'color # too low for W2003 - caused -2145263334 error and 462 error
    Set objTable = Nothing
    
Proc_Exit:
    Exit Sub
    
Proc_Err:
    Select Case Err.Number
        Case 4605 'this method or property is not available because the object is empty
            Resume Proc_Exit
        Case 5941 ' member does not exist
            Resume Proc_Exit
        Case 5825   'Object has been deleted
            Resume Proc_Exit
        Case 91     'object variable not set
            Resume Proc_Exit
        Case 4218   'type mismatch
            Resume Proc_Exit
        Case Else
            MsgBox Err.Number & " - " & Err.Description
            Resume Proc_Exit
    End Select
    Resume Proc_Exit
End Sub


Public Sub InsertTextAtBookMark(strBkmk As String, varText As Variant)
    Dim BMRange As Word.Range
    
    On Error GoTo Proc_Err
    
    Set BMRange = WordDoc.Bookmarks(strBkmk).Range
    '---- changes here ----
    'WordDoc.Bookmarks(strBkmk).Select    ' subsequent processing refers to selection
    BMRange.Text = varText & ""
    WordDoc.Bookmarks.Add strBkmk, BMRange
    BMRange.Select
    
Proc_Exit:
    Exit Sub
Proc_Err:
    Select Case Err.Number
        Case 4605 'this method or property is not available because the object is empty
            Resume Proc_Exit
        Case 5941, 6028 ' member does not exist/the range cannot be deleted
'            MsgBox "Bookmark {" & strBkmk & "} There is a mapping error with this document.  Please contact your administrator.", vbOKOnly+vbInformation
            Resume Proc_Exit
        Case 91     'object variable not set
            Resume Next
        Case 4218   'type mismatch
            Resume Proc_Exit
        Case Else
            MsgBox Err.Number & " - " & Err.Description
            Resume Proc_Exit
    End Select
    Resume Proc_Exit
End Sub