Case acLBGetValue
      'Возвращаем данные для указанной строки
      varRetval = sastrNames(lngRow)

varRetval = sastrNames(lngRow, lngCol)

Option Compare Database
Option Explicit

Function FillList(ctl As Control, VarID As Variant, lngRow As Long, lngCol As Long, intCode As Integer) As Variant
  Dim varRetval As Variant
  Dim intRows As Integer
  Dim intCols As Integer
  Static aData() As Variant
  
  Select Case intCode
    Case acLBInitialize
      'Код инициализации определяет число строк и колонок
      'необходимых для хранения списка, и переопределяет массив aData.
      ReDim aData(intRows, intCols)
      'Здесь должен находиться код, заполняющий этот массив
      varRetval = True
    Case acLBOpen
      'Возвращаем уникальный идентификатор. Для этого
      'используем встроенную функцию Timer
      varRetval = True
    Case acLBGetRowCount
      'Возвращаем число строк
      varRetval = intRows
    Case acLBGetColumnCount
      'Возвращаем число колонок
      varRetval = intCols
    Case acLBGetColumnWidth
      'Возвращаем значение ширины колонок. Если вернуть
      'значение, равное -1, Access установит для
      'данной колонки ширину по умолчанию.
      'Следовательно, это значение можно залдать в окне свойств.
      Select Case lngCol
        Case  0 
          'Задаем ширину первой колонки
          varRetval =  1440 
        Case  1 
          'Задаем ширину второй колонки и т.д.
          varRetval = - 1 
          'varRetval = 1440
        Case Else
          varRetval = - 1 
          'varRetval = 1440
      End Select
    Case acLBGetValue
      'Возвращаем значение элемента списка.
      'Здесь возвращается элемент массива
      'aData, заполненного кодом инициализации
      varRetval = aData(lngRow, lngCol)
    Case acLBGetFormat
      'Возвращаем строку формата
      'указанной строки и колонки
      Select Case lngCol
        Case  0 
          'Устанавливаем формат для всех колонок
          varRetval = "ddd"
      End Select
    Case acLBEnd
      '
      Erase aData
  End Select
  FillList = varRetval

End Function



Public Function FillCtrCombo(ctl As Control, VarID As Variant, lngRow As Long, lngCol As Long, intCode As Integer) As Variant
  'Заполняет список или поле со списком перечнем
  'таблиц или запросов базы данных
  '
  'Эти переменняе сохраняют свои значения
  'между вызовами функции
  Static sastrNames() As String
  Static sintItems As Integer
  
  Dim varRetval As Variant
  
  varRetval = Null
  Select Case intCode
    'инициализация
    Case acLBInitialize
      sastrNames = InitCtrArray()
      'Заносим в переменную массив имен.
      sintItems = FillCtrArray(sastrNames)
      'Сообщаем Access, что список подготовлен
      'и она может запрашивать его элементы.
      varRetval = (sintItems >  0 )
    Case acLBOpen
      'Назначаем элементу управления уникальный идентификатор
      varRetval = Timer
    Case acLBGetRowCount
      'Возвращаем количество строк
      varRetval = sintItems
    Case acLBGetValue
      'Возвращаем данные для указанной строки
      varRetval = sastrNames(lngRow, lngCol)
      
    Case acLBEnd
      'Освобождаем память
      Erase sastrNames
  End Select
  FillCtrCombo = varRetval
  
End Function

Private Function InitCtrArray() As Variant
  Dim astrItems() As String 'Variant
  Dim intCount As Long
  
  'With Application.CurrentData
  '  intCount = .AllTables.Count + .AllQueries.Count
  'End With
  'If intCount > 0 Then
  '  'Выделяем память под массив для хранения имен объектов
  '  ReDim astrItems(0 To intCount - 1)
  'End If
  
  Dim cnn As New ADODB.Connection
  Dim rst As New ADODB.Recordset
  
  cnn.Open "DRIVER=SQL Server;SERVER=EDURSS\SQL_URSS;APP=Microsoft Access;WSID=EDURSS;DATABASE=TB2K;Trusted_Connection=Yes"
  rst.CursorLocation = adUseClient
  rst.Open "EXEC CtrComboP 0 ", cnn, adOpenKeyset, adLockOptimistic, adCmdText
  intCount = rst.RecordCount
  If intCount >  0  Then
    'Выделяем память под массив для хранения имен объектов
    ReDim astrItems( 0  To rst.RecordCount -  1 ,  0  To  4 )
    'ReDim astrItems(0 To (intCount - 1) * 5)
  End If
    
  'astrItems = rst.GetRows(rst.RecordCount)
  'ReDim astrItems(0 To rst.RecordCount - 1)
  
  InitCtrArray = astrItems
  Set cnn = Nothing
  Set rst = Nothing
End Function

Private Function FillCtrArray(astrNames() As String) As Integer
  Dim intItems As Integer
  'Dim astrNames As Variant
  Dim cnn As New ADODB.Connection
  Dim rst As New ADODB.Recordset
  Dim I As Long
  On Error GoTo Err_Function
  
  cnn.Open "DRIVER=SQL Server;SERVER=EDURSS\SQL_URSS;APP=Microsoft Access;WSID=EDURSS;DATABASE=TB2K;Trusted_Connection=Yes"
  rst.CursorLocation = adUseClient
  rst.Open "EXEC CtrComboP 0 ", cnn, adOpenKeyset, adLockOptimistic, adCmdText
  
  intItems = rst.RecordCount
  If intItems >  0  Then
    'Выделяем память под массив для хранения имен объектов
    ReDim astrItems( 0  To intItems -  1 ,  0  To  4 )
    'ReDim astrItems(0 To (intCount - 1) * 5)
  End If
  
  'intItems = 0
  'Заполнение массива с просчетеом intItems
  rst.MoveFirst
  'astrNames = rst.GetRows
  'If Err > 0 Then
  For I =  0  To rst.RecordCount -  1 
    If rst.EOF Then Exit For
    astrNames(I,  0 ) = rst!CtrID
    astrNames(I,  1 ) = rst!CtrNick
    astrNames(I,  2 ) = rst!CtrName
    astrNames(I,  3 ) = rst!CtrAddr
    astrNames(I,  4 ) = rst!CtrID
  
    If Not rst.EOF Then rst.MoveNext
  Next I
  'End If
 
  If intItems >  0  Then
    ReDim Preserve astrNames( 0  To intItems -  1 ,  0  To  4 )
  End If
  FillCtrArray = intItems
  'Debug.Print rst.RecordCount
  'Debug.Print astrNames(100) & " " & astrNames(500) & " " & astrNames(15000)
  Set cnn = Nothing
  Set rst = Nothing
Exit_Function:
    DoCmd.Hourglass False
    DoCmd.SetWarnings True
    Exit Function
Err_Function:
    MsgBox Err.Number & " " & Err.Description
    Resume Exit_Function
End Function