Vba 从Access填充单词表

我正在尝试用MS Word创建表，并用MS Access中的数据填充它们。我写的所有代码都在下面的basMain和basUtilities中。我在basMain的私人分电池上遇到了麻烦。我以前使用过这个sub来用所有文本字段填充表格，但是这个表格需要允许其他格式。basUtilites中列出的数据是除tblEmployees.[Notes]和tblEmployees.[Photo]之外的所有文本。注释是一个备忘录，超过了文本字符的限制，照片是一张bmp图片。此外，这些表不应该有任何表单字段。在此方面的任何帮助都将不胜感激。谢谢

以下是指向源文件的链接：

巴斯曼

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

---

这个问题的性质与我在这里的回答（）中关于用Word从Excel中列出数据的问题类似。可能会有一些细微的差别，但它应该为你指明正确的方向。

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