如何设置组合框或列表框的行来源为函数
下列代码是一个例程,将行来源设置为这个函数:
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
|