Solved: Populating a Listbox (ADO method Access '97 into Excel '97)

[phendrena]

Hi there,

I have come across the following code on www.excelguru.ca and I was hoping that someone here might be able to help with a small problem that I am having. (Ken Puls, suggested asking here on his website....)

[vba]
Option Explicit
'Set reference to the Microsoft ActiveX Data Objects x.x Library!
'Global constants required
Const glob_sdbPath = "S:\BTeams\Ford\DST\Call Log Database\Dealer Support Database.mdb"
Const glob_sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & glob_sdbPath & ";"
Public Sub PopulateResults()
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: Populate the listbox with all values from the Access database
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim rcArray As Variant
Dim sSQL As String
'Set the location of your database, the connection string and the SQL query
sSQL = "SELECT Manual_Covernote_Log.DealerNumber, Manual_Covernote_Log.CustomerName " & _
"FROM Manual_Covernote_Log ORDER BY Manual_Covernote_Log.DealerNumber;"
'Open connection to the database
cnt.Open glob_sConnect

'Open recordset and copy to an array
rst.Open sSQL, cnt
rcArray = rst.GetRows
'Place data in the listbox
With frmCNSearch.lbxResults
.Clear
.ColumnCount = 2
.List = Application.Transpose(rcArray)
.ListIndex = -1
End With
'Close ADO objects
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
End Sub
[/vba]

When I run the above code I get an error : 'Run-time error 13: Type Mismatch' and the following is highlighted :
[vba]
.List = Application.Transpose(rcArray)
[/vba]

Can anyone suggest why this would be occuring?

Thanks,

[Bob Phillips]

Sounds like the recordset may be empty, hence so would the array.

Can you post the db as well so that we can try it?

[phendrena]

Database and spreadsheet as requested.

[levanduyet]

Dear Phendrena,
I have faced same problem. I have wrote another code to use as following:

[VBA]Function PopulateListboxFromSQL(sSQL As String, objListBox As MSForms.ListBox, _
Optional bShowError As Boolean = False, _
Optional sFont As String = "Verdana", _
Optional lFontSize As Long = 10, _
Optional BoundCol As Long = 1, _
Optional ColWidths As String, _
Optional LstWidth As Variant, _
Optional iStyle As fmListStyle = 0) As Long

'
' fmListStyle has 2 value:
' fmListStylePlain, value 0
' fmListStyleOption, value 1
'


'Note that:
'BoundColumn : Cot lay du lieu ve/Column to get data
'ColumnCount : is defined by rst.Fields.Count
'ColumnWidths : is the string to define the width of each column
'LstWidth : Listbox does not have this property
'
'Setting ColumnWidths:
'90;72;90 > The first column is 90 points (1.25 inch); the second column is 72 points (1 inch); the third column is 90 points.
'6 cm;0;6 cm > The first column is 6 centimeters; the second column is hidden; the third column is 6 centimeters. Because part of the third column is visible, a horizontal scroll bar appears.
'1.5 in;0;2.5 > in The first column is 1.5 inches, the second column is hidden, and the third column is 2.5 inches.
'2 in;;2 > in The first column is 2 inches, the second column is 1 inch (default), and the third column is 2 inches. Because only half of the third column is visible, a horizontal scroll bar appears.
'(Blank) > All three columns are the same width (1.33 inches).
'

'
' _ Check Is Nothing. Ex: If RsData Is Nothing Then ...
' + Check Empty If RsData.BOF And RsData.EOF Then ...
' + Check the quantity of records if you want to know before other action
' If RsData.Recordcount>0 Then
'
' If rsData Is Nothing Then
' 'Recordset chua duoc khoi tao
' MsgBox "The recordset did not create.",vbOKOnly, mcsAppName
' ElseIf rsData.EOF And rsData.BOF Then
' 'Khong co record nao thoa dieu kien cua cau SQL
' MsgBox "There are no any data to export.", vbOKOnly, mcsAppName
' Else
' 'Xuat du lieu ra
' Call RecordsetToRange(rsData, "REPORT")
' End If
'
'How to get back the value from ListBox, when the user click onto the ListBox?
'We will use the property List and ListIndex to get them back.
'The ListIndex property will return the order of item that you have selected
'and remember that the ListIndex will start with 0,1,2,...
'And the List property will return the item in which column that you want.
'also remember that this property start from 0,1,2,...
'so, let say, you want to get the value of the selected item, column 3,
'the code as following
' Msgbox ListBox1.List(ListBox1.ListIndex, 2)

Dim Rst As Object
Dim rcArray As Variant


On Error GoTo ErrorHandler
'Check the object name
If TypeName(objListBox) <> "ListBox" Then GoTo ErrorHandler

'Start the filling process
Set Rst = SqlGetRecordset(gcnAccess, sSQL, bShowError)
'Check status of rst
If Rst Is Nothing Then
'Do nothing
ElseIf Rst.EOF And Rst.BOF Then
'There are no any records according to this condition
'so Do nothing
Else
'Filling in the combobox
rcArray = Rst.getrows
With objListBox
.Clear
.ColumnCount = Rst.fields.Count
If LBound(rcArray, 2) = UBound(rcArray, 2) Then
.AddItem rcArray(LBound(rcArray, 1), LBound(rcArray, 2))
.List(0, 1) = rcArray(LBound(rcArray, 1) + 1, LBound(rcArray, 2))
Else
.List = TransposeDim(rcArray)
End If
.BoundColumn = BoundCol
.ColumnWidths = ColWidths
If Not IsMissing(LstWidth) Then
.ListWidth = LstWidth
End If
.Font = sFont
.Font.Size = lFontSize
.ListStyle = iStyle
End With

End If
PopulateListboxFromSQL = 1
ErrorExit:
Set Rst = Nothing
Exit Function

ErrorHandler:
PopulateListboxFromSQL = 0
If bCentralErrorHandler(mcsModName, "PopulateListboxFromSQL", , True) Then
Stop
Resume
Else
Resume ErrorExit
End If

End Function[/VBA]

And the TransposeDim Function as following:

[VBA]Private Function TransposeDim(V As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

Dim x As Long, y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant

Xupper = UBound(V, 2)
Yupper = UBound(V, 1)

ReDim tempArray(Xupper, Yupper)
For x = 0 To Xupper
For y = 0 To Yupper
tempArray(x, y) = V(y, x)
Next y
Next x
TransposeDim = tempArray

End Function[/VBA]

Hope the above code ok with you.

Le Van Duyet

[Bob Phillips]

Database and spreadsheet as requested.

password?

[phendrena]

For the VBA code : 0range
The rest should be unlocked... otherwise p1neapple to open the excel doc

[Bob Phillips]

I don't get a problem, works fine for me.

[Bob Phillips]

Although it does have problems later in trying to access coilumns 3,4,5 of a 2 column listbox.

[phendrena]

I don't get a problem, works fine for me.

Hi xld,

Did you try it in '97 or a later version?

Thanks,

[Bob Phillips]

I think it was 97 because I remembered you have 97, but it may have been 2000. I will try 97 again later today.

[phendrena]

Hi,

http://www.vbaexpress.com/forum/showthread.php?t=23651

I've come across the above post and the code in there appears to work for me. I do however, have one question about the sql statement....

I would like to add a search box. Instead of the listbox being populated in full when the form launches I would like the user to enter a dealer number and then have it search for that dealer number.

So I would like to use something like the following :-
[vba]
sSQL = "SELECT Manual_Covernote_Log.DateOfCall, Manual_Covernote_Log.DealerNumber, Manual_Covernote_Log.DealerName,
Manual_Covernote_Log.CustomerName, Manual_Covernote_Log.ChassisNumber, Manual_Covernote_Log.ManualCovernoteNumber, Manual_Covernote_Log.Vehicle, Manual_Covernote_Log.Comments " & _
"WHERE Manual_Covernote_Log.DealerNumber" = txtDCSearch.Value & _
"FROM Manual_Covernote_Log ORDER BY Manual_Covernote_Log.DateOfCall;"
[/vba]
(I am aware the that the WHERE is in the wrong place, and also of the dodgy line break)


How can I get that WHERE to work correctly?

Thanks,

[Kenneth Hobs]

Try:

ssql = "SELECT Manual_Covernote_Log.DateOfCall, Manual_Covernote_Log.DealerNumber, Manual_Covernote_Log.DealerName, " & _
"Manual_Covernote_Log.CustomerName, Manual_Covernote_Log.ChassisNumber, Manual_Covernote_Log.ManualCovernoteNumber, " & _
"Manual_Covernote_Log.Vehicle, Manual_Covernote_Log.Comments " & _
"WHERE Manual_Covernote_Log.DealerNumber = " & txtDCSearch.Value & _
"FROM Manual_Covernote_Log ORDER BY Manual_Covernote_Log.DateOfCall;"

[phendrena]

Try:

ssql = "SELECT Manual_Covernote_Log.DateOfCall, Manual_Covernote_Log.DealerNumber, Manual_Covernote_Log.DealerName, " & _
"Manual_Covernote_Log.CustomerName, Manual_Covernote_Log.ChassisNumber, Manual_Covernote_Log.ManualCovernoteNumber, " & _
"Manual_Covernote_Log.Vehicle, Manual_Covernote_Log.Comments " & _
"WHERE Manual_Covernote_Log.DealerNumber = " & txtDCSearch.Value & _
"FROM Manual_Covernote_Log ORDER BY Manual_Covernote_Log.DateOfCall;"

Nicely done, thank you