gmaxey
10-11-2011, 05:39 AM
Hi,
I dabble a bit in Word VBA and from time to time I need to get information from an Excel file. I don't understand all of the mechanics of doing that and I usually just adapt code that I have found posted on the internet to meet my needs. I am currently working on a Word userform that contains five linked listboxes (i.e., selection in first box determines list entries in second box, selection in second box determines list entries in third box and so on.).
Reduced in scope and very simplistic, my Excel file might look like this:
1 A Dogs
2 A Cats
3 A Birds
4 B Boxer
5 B Collie
6 C Siamese
7 C Tabby
8 D Parrot
9 D Bluebird
When the form is displayed all of the items coded "A" are populated in listbox1. If the user clicked "Dogs" then all of the items coded "B" are populated in listbox 2.
I haved some code that is working. It takes the listbox and "Parent_ID" which would be "A, B, C, etc." using the simple example above as arguments, but it uses the "ADODB.recordset" process and I was wondering if was a simplier way using only Excel methods to do the same thing. Code follows. Thanks.
Option Explicit
Const m_Directory = "D:\Data Stores"
Dim m_strFilterField As String
Dim m_strFilterValue As String
Dim m_strQuery As String
'****************************************************************
Sub FillListBox(ByRef List As ListBox, ByVal Parent_ID As String)
Dim arrData() As Variant
Dim lngRows As Long
Dim lngCols As Long
Dim lngRow As Long
Dim lngCol As Long
Dim oRS As New ADODB.Recordset
Application.ScreenUpdating = False
Set oRS = GetList(Parent_ID)
lngRows = oRS.RecordCount
lngCols = oRS.Fields.Count
'No matching list entries found so clear the list manually.
If lngRows = 0 Then
List.Clear
Else
'Set the userform listbox column count and hide columns 1, 2 and 3
List.ColumnCount = lngCols
List.ColumnWidths = "0,0,0"
ReDim arrData(lngRows - 1, lngCols - 1)
For lngRow = 0 To lngRows - 1
For lngCol = 0 To lngCols - 1
arrData(lngRow, lngCol) = oRS(lngCol)
Next lngCol
oRS.MoveNext
Next lngRow
'Load data into ListBox1
List.List() = arrData
End If
'Release Objects
Set oRS = Nothing
End Sub 'FillListBox
'***********************************************************
Function GetList(ByVal ParentID) As Object
' Purpose: Retrieves data for a List from LISTS.CSV by ParentID
' Assumptions: Lists.csv has entries for the ParentID requested.
' Inputs: ParentID - A string representing the List to retrieve.
' Returns: A recordset object containing the fields returned.
m_strQuery = "Select * from [LISTS#CSV]"
m_strFilterField = "Parent_ID"
m_strFilterValue = UCase(ParentID)
Set GetList = CreateObject("ADODB.Recordset")
QueryDB GetList, m_strQuery, "", m_strFilterField, m_strFilterValue, True
End Function
'***********************************************************
Function GetListItem(ByVal UID) As Object
' Purpose: Retrieves data for a List from LISTS.CSV by UID
' Assumptions: Lists.csv has a unique entry for the UID requested.
' Inputs: ParentID - A string representing the List to retrieve.
' Returns: A recordset object containing the fields returned.
m_strQuery = "Select * from [LISTS#CSV]"
m_strFilterField = "UID"
m_strFilterValue = UCase(UID)
Set GetListItem = CreateObject("ADODB.Recordset")
QueryDB GetListItem, m_strQuery, "", m_strFilterField, m_strFilterValue, True
End Function
'***********************************************************
Function QueryDB(oRS_Passed As Object, strQuery As String, strSortField As String, strFilterField As String, strFilterValue As String, bExactMatch As Boolean)
' Purpose: Retrieves data from the database.
' Assumptions: strConnect is a global that has been set.
' Inputs:
' oRS_Passed - A recordset object to be populated by Query.
' strQuery - The query to execute.
' strSortField - field name to sort on.
' strFilterField - field name by which the result set should be limited.
' strFilterValue - value to filter the above field name by.
' bExactMatch - Boolean specifying whether the query be an = or like query.
'
' Returns: A recordset object containing the records returned.
Dim strConnect As String
Dim oConnection As Object
Dim strCompositeQuery
Dim bRtnStatus
Const adUseClient = 3
Const adOpenStatic = 3
Const adReadOnly = 1
Const adCmdText = 1
Const OPERATOR_OR = "||"
Const OPERATOR_AND = "&&"
bRtnStatus = True
Set oConnection = CreateObject("ADODB.Connection")
'When a directory has not been specified by the user, assume default directory.
If strConnect = "" Then
strConnect = "Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & m_Directory & ";Extensions=csv,txt;Persist Security Info=False;Mode=Read;"
End If
oConnection.ConnectionString = strConnect
oConnection.Open
oRS_Passed.CursorLocation = adUseClient
'Using the filter parameters passed - generate a where clause appropriate to the filter value presented.
If UCase(strFilterValue) <> "NULL" Then
strFilterValue = Replace(LCase(strFilterValue), "'", "''")
End If
If strFilterField <> "" Then
If UCase(strFilterValue) = "NULL" Then
strCompositeQuery = strQuery & " where " & strFilterField & " IS NULL"
Else
'If explicitly requested to be an exact match and no wildcard chars specified, use exact match, i.e. =, in the where clause.
If bExactMatch And (InStr(strFilterValue, "%") = 0) Then
strCompositeQuery = strQuery & " where LCase(" & strFilterField & ") = '" & strFilterValue & "'"
Else
If (InStr(strFilterValue, "%") <> 0) Then
strFilterValue = Replace(strFilterValue, OPERATOR_OR, "' OR LCase(" & strFilterField & ") LIKE '")
strFilterValue = Replace(strFilterValue, OPERATOR_AND, "' AND LCase(" & strFilterField & ") LIKE '")
strCompositeQuery = strQuery & " where LCase(" & strFilterField & ") LIKE '" & strFilterValue & "'"
Else
strCompositeQuery = strQuery & " where LCase(" & strFilterField & ") LIKE '" & strFilterValue & "%'"
End If 'Not (Instr...
End If 'bExactMatch
End If
Else
strCompositeQuery = strQuery
End If
'If a sort field specified, add an order by clause.
If strSortField <> "" Then strCompositeQuery = strCompositeQuery & " Order by " & strSortField
On Error Resume Next
oRS_Passed.Open strCompositeQuery, oConnection, adOpenStatic, adReadOnly, adCmdText
oRS_Passed.ActiveConnection = Nothing
oConnection.Close
'We assume that if the oConnection.close fails, that there was not a successful retrieve of the recordset in the first place.
If Err.Number > 0 Then
bRtnStatus = False
End If
On Error GoTo 0
Set oConnection = Nothing
QueryDB = bRtnStatus
End Function
I dabble a bit in Word VBA and from time to time I need to get information from an Excel file. I don't understand all of the mechanics of doing that and I usually just adapt code that I have found posted on the internet to meet my needs. I am currently working on a Word userform that contains five linked listboxes (i.e., selection in first box determines list entries in second box, selection in second box determines list entries in third box and so on.).
Reduced in scope and very simplistic, my Excel file might look like this:
1 A Dogs
2 A Cats
3 A Birds
4 B Boxer
5 B Collie
6 C Siamese
7 C Tabby
8 D Parrot
9 D Bluebird
When the form is displayed all of the items coded "A" are populated in listbox1. If the user clicked "Dogs" then all of the items coded "B" are populated in listbox 2.
I haved some code that is working. It takes the listbox and "Parent_ID" which would be "A, B, C, etc." using the simple example above as arguments, but it uses the "ADODB.recordset" process and I was wondering if was a simplier way using only Excel methods to do the same thing. Code follows. Thanks.
Option Explicit
Const m_Directory = "D:\Data Stores"
Dim m_strFilterField As String
Dim m_strFilterValue As String
Dim m_strQuery As String
'****************************************************************
Sub FillListBox(ByRef List As ListBox, ByVal Parent_ID As String)
Dim arrData() As Variant
Dim lngRows As Long
Dim lngCols As Long
Dim lngRow As Long
Dim lngCol As Long
Dim oRS As New ADODB.Recordset
Application.ScreenUpdating = False
Set oRS = GetList(Parent_ID)
lngRows = oRS.RecordCount
lngCols = oRS.Fields.Count
'No matching list entries found so clear the list manually.
If lngRows = 0 Then
List.Clear
Else
'Set the userform listbox column count and hide columns 1, 2 and 3
List.ColumnCount = lngCols
List.ColumnWidths = "0,0,0"
ReDim arrData(lngRows - 1, lngCols - 1)
For lngRow = 0 To lngRows - 1
For lngCol = 0 To lngCols - 1
arrData(lngRow, lngCol) = oRS(lngCol)
Next lngCol
oRS.MoveNext
Next lngRow
'Load data into ListBox1
List.List() = arrData
End If
'Release Objects
Set oRS = Nothing
End Sub 'FillListBox
'***********************************************************
Function GetList(ByVal ParentID) As Object
' Purpose: Retrieves data for a List from LISTS.CSV by ParentID
' Assumptions: Lists.csv has entries for the ParentID requested.
' Inputs: ParentID - A string representing the List to retrieve.
' Returns: A recordset object containing the fields returned.
m_strQuery = "Select * from [LISTS#CSV]"
m_strFilterField = "Parent_ID"
m_strFilterValue = UCase(ParentID)
Set GetList = CreateObject("ADODB.Recordset")
QueryDB GetList, m_strQuery, "", m_strFilterField, m_strFilterValue, True
End Function
'***********************************************************
Function GetListItem(ByVal UID) As Object
' Purpose: Retrieves data for a List from LISTS.CSV by UID
' Assumptions: Lists.csv has a unique entry for the UID requested.
' Inputs: ParentID - A string representing the List to retrieve.
' Returns: A recordset object containing the fields returned.
m_strQuery = "Select * from [LISTS#CSV]"
m_strFilterField = "UID"
m_strFilterValue = UCase(UID)
Set GetListItem = CreateObject("ADODB.Recordset")
QueryDB GetListItem, m_strQuery, "", m_strFilterField, m_strFilterValue, True
End Function
'***********************************************************
Function QueryDB(oRS_Passed As Object, strQuery As String, strSortField As String, strFilterField As String, strFilterValue As String, bExactMatch As Boolean)
' Purpose: Retrieves data from the database.
' Assumptions: strConnect is a global that has been set.
' Inputs:
' oRS_Passed - A recordset object to be populated by Query.
' strQuery - The query to execute.
' strSortField - field name to sort on.
' strFilterField - field name by which the result set should be limited.
' strFilterValue - value to filter the above field name by.
' bExactMatch - Boolean specifying whether the query be an = or like query.
'
' Returns: A recordset object containing the records returned.
Dim strConnect As String
Dim oConnection As Object
Dim strCompositeQuery
Dim bRtnStatus
Const adUseClient = 3
Const adOpenStatic = 3
Const adReadOnly = 1
Const adCmdText = 1
Const OPERATOR_OR = "||"
Const OPERATOR_AND = "&&"
bRtnStatus = True
Set oConnection = CreateObject("ADODB.Connection")
'When a directory has not been specified by the user, assume default directory.
If strConnect = "" Then
strConnect = "Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & m_Directory & ";Extensions=csv,txt;Persist Security Info=False;Mode=Read;"
End If
oConnection.ConnectionString = strConnect
oConnection.Open
oRS_Passed.CursorLocation = adUseClient
'Using the filter parameters passed - generate a where clause appropriate to the filter value presented.
If UCase(strFilterValue) <> "NULL" Then
strFilterValue = Replace(LCase(strFilterValue), "'", "''")
End If
If strFilterField <> "" Then
If UCase(strFilterValue) = "NULL" Then
strCompositeQuery = strQuery & " where " & strFilterField & " IS NULL"
Else
'If explicitly requested to be an exact match and no wildcard chars specified, use exact match, i.e. =, in the where clause.
If bExactMatch And (InStr(strFilterValue, "%") = 0) Then
strCompositeQuery = strQuery & " where LCase(" & strFilterField & ") = '" & strFilterValue & "'"
Else
If (InStr(strFilterValue, "%") <> 0) Then
strFilterValue = Replace(strFilterValue, OPERATOR_OR, "' OR LCase(" & strFilterField & ") LIKE '")
strFilterValue = Replace(strFilterValue, OPERATOR_AND, "' AND LCase(" & strFilterField & ") LIKE '")
strCompositeQuery = strQuery & " where LCase(" & strFilterField & ") LIKE '" & strFilterValue & "'"
Else
strCompositeQuery = strQuery & " where LCase(" & strFilterField & ") LIKE '" & strFilterValue & "%'"
End If 'Not (Instr...
End If 'bExactMatch
End If
Else
strCompositeQuery = strQuery
End If
'If a sort field specified, add an order by clause.
If strSortField <> "" Then strCompositeQuery = strCompositeQuery & " Order by " & strSortField
On Error Resume Next
oRS_Passed.Open strCompositeQuery, oConnection, adOpenStatic, adReadOnly, adCmdText
oRS_Passed.ActiveConnection = Nothing
oConnection.Close
'We assume that if the oConnection.close fails, that there was not a successful retrieve of the recordset in the first place.
If Err.Number > 0 Then
bRtnStatus = False
End If
On Error GoTo 0
Set oConnection = Nothing
QueryDB = bRtnStatus
End Function