带列标题的AddAllToList

此函数最初是在时间的曙光中创建的，多年来，我进行了许多更改，并且在搜索网络后，我仍然看不到1允许使用列标题，因此我想我应该发布一个做。

在控件属性上，只需对列标题单击“是”或“否”即可。

您可以使用Tag属性来确定列和显示的单词。

2; <无选择>

为了帮助您保存单击，此功能还将在您刚刚添加的列表中选择项目，如果您决定将其删除，则在功能的下部进行注释。

如果您需要有关此功能实现的更多信息，可以在这里找到：

http://support.microsoft.com/kb/128881

Function AddAllToList(ctl As Control, lngID As Long, lngRow As Long, _
lngCol As Long, intCode As Integer) As Variant
On Error GoTo Err_AddAllToList
      Static dbs As Database, rst As Recordset
      Static lngDisplayID As Long
      Static intDisplayCol As Integer
      Static strDisplayText As String
      Static ctlVal As String
      Dim intSemiColon As Integer
      Select Case intCode
         Case acLBInitialize
            If lngDisplayID <> 0 Then
               MsgBox "AddAllToList is already in use by another control!"
               AddAllToList = False
               Exit Function
            End If
            If ctl.Tag > "" Then
                intSemiColon = InStr(ctl.Tag, ";")
               If intSemiColon = 0 Then
                  intDisplayCol = Val(ctl.Tag)
               Else
                  intDisplayCol = Val(Left(ctl.Tag, intSemiColon - 1))
                  strDisplayText = Mid(ctl.Tag, intSemiColon + 1)
               End If
            Else
                intDisplayCol = 1
                strDisplayText = "(All)"
            End If
            ctlVal = strDisplayText
            Set dbs = CurrentDb
            Set rst = dbs.OpenRecordset(ctl.RowSource, dbOpenSnapshot)
            lngDisplayID = Timer
            AddAllToList = lngDisplayID
         Case acLBOpen
            AddAllToList = lngDisplayID
         Case acLBGetRowCount
            On Error Resume Next
            rst.MoveLast
            If ctl.ColumnHeads = True Then
                AddAllToList = rst.RecordCount + 2
            Else
                AddAllToList = rst.RecordCount + 1
            End If
         Case acLBGetColumnCount
            AddAllToList = rst.Fields.Count
         Case acLBGetColumnWidth
            AddAllToList = -1
         Case acLBGetValue
            If ctl.ColumnHeads = True Then
                If lngRow = 0 Then
                        AddAllToList = rst.Fields(lngCol).Name
                ElseIf lngRow = 1 Then
                    If lngCol = intDisplayCol - 1 Then
                        AddAllToList = strDisplayText
                    Else
                        AddAllToList = Null
                    End If
                Else
                    rst.MoveFirst
                    rst.Move lngRow - 2
                    AddAllToList = rst(lngCol)
                End If
            Else
                If lngRow = 0 Then
                    If lngCol = intDisplayCol - 1 Then
                        AddAllToList = strDisplayText
                    Else
                        AddAllToList = Null
                    End If
                Else
                    rst.MoveFirst
                    rst.Move lngRow - 1
                    AddAllToList = rst(lngCol)
                End If
            End If
         Case acLBEnd
            lngDisplayID = 0
            rst.Close
'The following if statement selects the item in the list that you have just added
            If ctlVal <> "" Then
                ctl.Value = ctlVal
            End If
            Set rst = Nothing
            Set dbs = Nothing
      End Select
Bye_AddAllToList:
      Exit Function 
Err_AddAllToList:
    MsgBox Err.Description, vbOKOnly + vbCritical, "AddAllToList"
    AddAllToList = False
    Resume Bye_AddAllToList
End Function

From: https://bytes.com/topic/access/insights/869119-addalltolist-column-headers