Question

我正在尝试在MS Word中创建表格并用MS Access中的数据填充它们。我写的所有代码都在basMain和basUtilities中。我在basMain的Private Sub FillCells遇到了麻烦。我以前使用此子来填充包含所有文本字段的表，但是此表需要允许其他格式。 basUtilites中列出的数据是除tblEmployees之外的所有文本。[Notes]和tblEmployees。[Photo]。这些笔记是一个备忘录，超过了文字的字符限制，照片是一张bmp图片。此外，表格不应包含任何表单字段。对此有任何帮助表示赞赏。谢谢!!

以下是源文件的链接：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

从Access填充Word表

0 个答案: