Help with populating tables in Word VBA

[tarahoverson]

I am trying to create tables in MS Word and fill them with data from MS Access. All of the code I have written is below in basMain and basUtilities. I am having trouble with Private Sub FillCells in basMain. I previously used this sub to fill tables with all text fields, however this table needs to allow other formats. The data listed in basUtilites is all text except tblEmployees.[Notes] and tblEmployees.[Photo]. The [Notes] are a memo and over the limit of characters for text and the [Photo] is a bmp picture. Also, the tables should not have any form fields. Any help with this is appreciated. Thank you!!

Unfortunately the source Access file will not upload.


basMain

Option Explicit
Public Const cstrPath As String = "\Source\243SRC_Final.accdb"
Public connEmp As ADODB.Connection
Public rstEmps As ADODB.Recordset
Sub ListEmps()
Dim strAsk As String
strAsk = InputBox("Which country?", "County Request")
If strAsk = "UK" Then
Call basUtilities.connect("UK")
ElseIf strAsk = "USA" Then
Call basUtilities.connect("USA")
Else
MsgBox "This name is not recognized!"
End If
End Sub
Public Sub CreateTables()
Dim sngRecords As Single, intFields As Integer, intI As Integer
sngRecords = rstEmps.RecordCount
intFields = rstEmps.Fields.Count
rstEmps.MoveFirst
For intI = 1 To sngRecords
Dim intF As Integer
Selection.TypeParagraph
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=intFields, NumColumns:= _
2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitContent
With Selection.Tables(1)
.Columns.PreferredWidth = InchesToPoints(6)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
Call FillCells(intFields)
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
rstEmps.MoveNext
Next intI
rstEmps.Close
connEmp.Close
Set rstEmps = Nothing
Set connEmp = Nothing
ActiveWindow.ActivePane.View.ShowAll = True
End Sub
Private Sub FillCells(intFields As Integer)
Dim intF As Integer
For intF = 0 To intFields - 1
Dim strFieldName As String
strFieldName = Right(rstEmps.Fields(intF).Name, _
Len(rstEmps.Fields(intF).Name))
Selection.TypeText Text:=strFieldName
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
Selection.MoveRight Unit:=wdCell
Selection.Fields.Add Range:=Selection.Range, _
Type:=wdFieldFormTextInput
Selection.PreviousField.Select
With Selection.FormFields(1)
.Name = "txt" & strFieldName
.Enabled = True
.OwnHelp = False
.OwnStatus = False
With .TextInput
.EditType Type:=wdRegularText, _
Default:=rstEmps.Fields(intF).Value, Format:=""
.Width = 0
End With
End With
Selection.MoveLeft Unit:=wdCell
If intF <> (intFields - 1) Then
Selection.MoveDown Unit:=wdLine, Count:=1
End If
Next intF
End Sub

basUtilities

Option Explicit
Public Sub connect(strVar As String)
Dim strEmps As String, strPath As String
strEmps = "SELECT tblEmployees.[FirstName], tblEmployees.[LastName], tblEmployees.[Notes], tblEmployees.[photo] "
strEmps = strEmps & "FROM tblEmployees "
strEmps = strEmps & "WHERE tblEmployees.[Country]= '" & strVar & "' ORDER BY tblEmployees.[LastName]"
strPath = ThisDocument.Path & cstrPath
Set connEmp = New ADODB.Connection
Set rstEmps = New ADODB.Recordset
connEmp.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & strPath & "'"
rstEmps.Open strEmps, connEmp, adOpenKeyset, adLockOptimistic
Call CreateTables
End Sub

[macropod]

Is there a reason you don't use mailmerge for this? And, given that you say "the tables should not have any form fields", why are you adding them? You also say "this table needs to allow other formats" but you don't say what you mean. The data format tables can contain include text, graphics, other tables, formfields, content controls, etc. and text can be formatted in a myriad of ways.