MS Word Раскрывающийся список или поле со списком из MS Access Database

Question

Я пытаюсь заполнить поле со списком или раскрывающийся список из базы данных доступа.Я использовал следующий веб-сайт для шаблона кода.Я изменил его в соответствии со своими потребностями.Я получаю сообщение об ошибке: 5941 Запрашиваемый элемент коллекции не существует "

Исходный код: http://www.fontstuff.com/mailbag/qword02.htm

Мой код:

Private Sub Document_Open()
    On Error GoTo Document_Open_Err

    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset

    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=*path to database removed for post*;"
    rst.Open "SELECT DISTINCT TOP 25 [Equipment] FROM tblEquipment ORDER BY [Equipment];", _
        cnn, adOpenStatic
    rst.MoveFirst

    With ActiveDocument.FormFields("Equipment").DropDown.ListEntries
        .Clear
        Do
            .Add rst![Equipment]
            rst.MoveNext
        Loop Until rst.EOF
    End With
Document_Open_Exit:
    On Error Resume Next
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    Exit Sub
Document_Open_Err:
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
    Resume Document_Open_Exit
End Sub

Код, который почтиработы:

Private Sub Document_Open()
    On Error GoTo Document_Open_Err

    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset

    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=*removed for post*;"
    rst.Open "SELECT DISTINCT TOP 25 [Field1] FROM Equipment_List ORDER BY [Field1];", _
        cnn, adOpenStatic
    rst.MoveFirst

    With ActiveDocument.FormFields("Equipment").DropDown.ListEntries
        .Clear
        Do
            .Add rst![Field1]
            rst.MoveNext
        Loop Until rst.EOF
    End With
Document_Open_Exit:
    On Error Resume Next
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    Exit Sub
Document_Open_Err:
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Error!"
    Resume Document_Open_Exit
End Sub

Answer 1

Я обновляю свой последний пост здесь.Смотрите код ниже;установите ссылку на DAO и сделайте пару небольших изменений в соответствии с вашими потребностями.

Option Explicit
'Requires a reference to the '"Microsoft DAO 3.51 (or 3.6) Object Library."
Private Sub Userform_Initialize()
Dim myDataBase As DAO.Database
Dim myActiveRecord As DAO.Recordset
Dim i As Long
  'Open the database to retrieve data
  Set myDataBase = OpenDatabase("D:\Data Stores\sourceAccess.mdb")
  'Define the first recordset
  Set myActiveRecord = myDataBase.OpenRecordset("Table1", dbOpenForwardOnly)
  'Set the listbox column count
  ListBox1.ColumnCount = myActiveRecord.Fields.Count
  i = 0
  'Loop through all the records in the table until the EOF marker is reached.
  Do While Not myActiveRecord.EOF
    'Use .AddItem method to add a new row for each record
    ListBox1.AddItem
    ListBox1.List(i, 0) = myActiveRecord.Fields("Employee Name")
    ListBox1.List(i, 1) = myActiveRecord.Fields("Employee DOB")
    ListBox1.List(i, 2) = myActiveRecord.Fields("Employee ID")
    i = i + 1
    'Get the next record
    myActiveRecord.MoveNext
  Loop
  'Close the database and clean-up
  myActiveRecord.Close
  myDataBase.Close
  Set myActiveRecord = Nothing
  Set myDataBase = Nothing
lbl_Exit:
  Exit Sub
End Sub

Private Sub CommandButton1_Click()
Dim oRng As Word.Range
Dim oBM As Bookmarks
  Set oBM = ActiveDocument.Bookmarks
  Set oRng = oBM("EmpName").Range
  oRng.Text = ListBox1.Text
  oBM.Add "EmpName", oRng
  Set oRng = oBM("EmpDOB").Range
  oRng.Text = ListBox1.List(ListBox1.ListIndex, 1)
  oBM.Add "EmpDOB", oRng
  Set oRng = oBM("EmpID").Range
  oRng.Text = ListBox1.List(ListBox1.ListIndex, 2)
  oBM.Add "EmpID", oRng
  Me.Hide
lbl_Exit:
  Exit Sub
End Sub

Код Источник:

https://gregmaxey.com/word_tip_pages/populate_userform_listbox_or_combobox.html