如何设置组合框或列表框的行来源为函数
下列代码是一个例程，将行来源设置为这个函数：
Public Function valueList(ctl As Control, _
varID As Variant, _
lngRow As Long, _
lngCol As Long, _
intCode As Integer) As Variant
Dim varRetVal As Variant
Dim strField As String
Dim strField As String
Dim strSQL As String
Dim strList As String
Dim intLoopRow As Integer
Dim intLoopCol As Integer
Dim cnn As ADODB.Connection
Dim RST As ADODB.Recordset
Static svarArray() As Variant
Static sintRows As Integer
Static sintCols As Integer
On Error GoTo Proc_err
Select Case intCode
Case acLBInitialize
On Error Resume Next
intLoopRow = Ubound(svarArray)
If Err <> 0 Then
On Error GoTo Proc_err
'populate the customer recordset
Set cnn = New ADODB.Connection
cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
cnn.Properties("Data Source") = CurrentProject.Path & "\data share\data.dat"
cnn.Properties("Jet OLEDB:Database Password") = "123456789222"
cnn.Open
' With cnn
'.Provider = "Microsoft.Jet.OLEDB.4.0"
'this gets stored values from the only
'local table to allow flexibility
'.ConnectionString = CurrentProject.Path & "\data.dat" 'should be changed
'.Properties("Jet OLEDB:Database Password") = "123456789222"
'.Open
'End With
Set RST = New ADODB.Recordset
With RST
.ActiveConnection = cnn
.Source = "select usysuser.userid,usysuser.username from usysuser" 'should be changed
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockReadOnly
.Open , , , , adCmdText
.MoveLast
sintRows = .RecordCount
.MoveFirst
sintCols = .Fields.Count
End With 'rst
Set cnn = Nothing
ReDim svarArray(sintRows, sintCols)
For intLoopRow = 0 To sintRows - 1
svarArray(intLoopRow, 0) = RST(0)
svarArray(intLoopRow, 1) = RST(1)
' MsgBox rst(0) & rst(1)
RST.MoveNext
Next
RST.Close
End If
varRetVal = True
Case acLBOpen '1
'return a unique ID code
varRetVal = Timer
Case acLBGetRowCount '3
' Return number of rows
varRetVal = sintRows
Case acLBGetColumnCount '4
' Return number of fields (columns)
varRetVal = sintCols
Case acLBGetColumnWidth '5
'return the column widths or
'-1 for the default width for the column
' varRetVal = -1 'default width
Select Case lngCol
Case 0
'hide the first column
varRetVal = 0
Case 1
'return the default width for column 2
varRetVal = -1
End Select
Case acLBGetValue '6
'Return actual data
varRetVal = svarArray(lngRow, lngCol)
'If lngRow = 0 Then
'varRetVal = Null
' End If
Case acLBGetFormat '7
'return the formatting info for the row/column
Select Case lngCol
Case 0
Case 1
End Select
Case acLBEnd '9
'clean up
On Error Resume Next
Erase svarArray
Set RST = Nothing
Set cnn = Nothing
End Select
Proc_exit:
On Error Resume Next
valueList = varRetVal
Exit Function
Proc_err:
'MsgBox Err.Number & "--" & Err.Description & vbCrLf & "CustomerList"
varRetVal = False
Resume Proc_exit
End Function
