Динамический список, заполненный набором записей ADODB, не отображает элементы, когда количество записей равно 1 - PullRequest
Новая
       35

Динамический список, заполненный набором записей ADODB, не отображает элементы, когда количество записей равно 1

0 голосов
/ 24 октября 2019

Привет, у меня проблема со списком.

Я хочу проверить, сколько людей сидит (за каждым столом) в ресторане, а также проверить, сколько людей ждут, чтобы сесть. Для этого я использую лист ("LunchRoom") в качестве базы данных, и с набором записей ADODB я получаю результаты для каждой таблицы.

Я не могу понять, почему, если в списке есть только одна запись, которой он не являетсяне заселены? 

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

enter image description here

1 Ответ

1 голос
/ 24 октября 2019

Когда вы Transpose возвращаете двумерный массив из GetRows, если измерение «строки» имеет только один слот, вы получаете массив 1-D, а не перевернутый 2-D массивожидая.

Вы можете увидеть это, если посмотреть на окно Watch: я выполнил запрос, возвращающий только одну строку, использовал GetRows для заполнения arr, затем использовал Transpose для заполнения arr2 -

enter image description here

Обратите внимание, что arr2 является одномерным массивом. Сравните это с тем же кодом и набором из двух записей ниже:

enter image description here

Вместо использования Application.Transpose попробуйте использовать функцию VBA, как здесь: https://bettersolutions.com/vba/arrays/transposing.htm

...