当记录数为 1 时，由 ADODB 记录集填充的动态列表框不显示项目

Question

您好，我的列表框有问题。

我想查看一家餐厅有多少人就座（每个 table），还想查看有多少人在等着就座。为此，我使用 sheet("LunchRoom") 作为数据库，并使用 ADODB 记录集获取每个 table.

的结果

我不明白为什么如果列表框只有一条记录却没有被填充？

Sub UserForm_Initialize()

    Dim ctrl As Control
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim i As Integer, L As Integer, T As Integer, W As Integer, H As Integer
    Dim strsql As String
    Dim ArrTables, arr, arrPax, lbx As ListBox

    Const adOpenStatic = 3
    Const adLockOptimistic = 3
    Const adCmdText = &H1
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Set rs = New ADODB.Recordset
    Set LBs = New Collection

    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & ThisWorkbook.FullName & "; Extended Properties=""Excel 8.0;HDR=Yes;"";"

    strsql = "Select IdClients, Paxname, PaxSurname from [LunchRoom$] where Table is null"
    rs.Open strsql, cn, adOpenStatic, adLockReadOnly, adCmdUnspecified

    If rs.EOF Then lbPaxNoTable.Caption = "Noboby can be seat": GoTo PaxOnTable

    rs.MoveFirst
    arr = rs.GetRows

    With Me.LbxPaxNotSeating
        .Clear
        .ColumnCount = 3
        .ColumnWidths = "0;30;30"
        .List = Application.Transpose(arr)
        .ListIndex = 0
    End With

    lbPaxNoTable.Caption = rs.RecordCount & " people wait to sit down"

    PaxOnTable:
    Set rs = Nothing

    strsql = "Select distinct Table FROM [Tables$]"
    rs.Open strsql, cn, adOpenStatic, adLockReadOnly, adCmdUnspecified
    ReDim ArrTables(0 To rs.RecordCount)

    i = 0
    Do Until rs.EOF
        ArrTables(i) = rs![Table]
        rs.MoveNext
        i = i + 1
    Loop
    Set rs = Nothing

    L = 24
    T = 150
    W = 165
    H = 94

    For i = 0 To UBound(ArrTables) - 1
        If i = 3 Then T = 252: L = 24
        strsql = "Select IdClients, Paxname, PaxSurname from [LunchRoom$] where Table = '" & ArrTables(i) & "'"
        rs.Open strsql, cn, adOpenStatic, adLockReadOnly, adCmdUnspecified
        If rs.EOF Then arrPax = Null Else arrPax = rs.GetRows
        Call Add_Dynamic_lbx(ArrTables(i), "Forms.ListBox.1", arrPax, L, T, H, W)
        Me.Controls("lb" & ArrTables(i)).Caption = rs.RecordCount & " people are seated on " & ArrTables(i)
        L = L + 3 + W
        Set rs = Nothing
    Next i

    Dim lb As MSForms.ListBox
    Dim LMB As ListBoxDragAndDropManager
    Set LBs = New Collection

    For Each ctrl In Me.Controls
        If TypeName(ctrl) = "ListBox" Then
            Set LMB = New ListBoxDragAndDropManager
            Set LMB.ThisListBox = ctrl
            LBs.Add LMB
        End If
    Next

    fastexit:
    Set rs = Nothing
    Set cn = Nothing

End Sub

Sub Add_Dynamic_lbx(ByVal nome As String, ctr As String, val, L As Integer, T As Integer, H As Integer, W As Integer)

    Dim lbl As Control, code As String, NextLine As Long
    Set lbl = FrmPlan.Controls.Add(ctr)
    With lbl
        .name = nome
        .Clear
        .ColumnCount = 3
        If Not IsNull(val) Then
            .List = Application.Transpose(val):
            .ListIndex = -1
        End If
        .Width = W
        .ColumnWidths = "0;30;150"               '1th=0 to hide the IdRst
        .Height = H
        .Left = L
        .Top = T
        .ControlTipText = nome
    End With

End Sub

Answer 1

当你 Transpose 从 GetRows 返回一个二维数组时，如果 "rows" 维度只有一个槽，那么你会得到一个一维数组，而不是翻转了您期望的二维数组。

如果您查看 Watch window，您会看到这一点：我运行一个只返回一行的查询，使用 GetRows 填充 arr，然后使用Transpose 填充 arr2 -

注意arr2是一维数组。将其与下面的相同代码和两个记录结果集进行比较：

不要使用 Application.Transpose，而是尝试使用 VBA 函数，如下所示： https://bettersolutions.com/vba/arrays/transposing.htm

当记录数为 1 时，由 ADODB 记录集填充的动态列表框不显示项目

Dynamic listbox populated by ADODB recordset doesn't display items when record count is 1

excel

vba

listbox

adodb