Populating Word Tables from Access

Question

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!!

Here is a link to source files: https://jumpshare.com/b/Sy6mxurdTdpSSdcqKLUJ

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