Digitborn.com
Active Member
- Joined
- Apr 3, 2007
- Messages
- 353
Option Explicit
'#########################################################
'# #
'# References need to be set in the VBE to the following #
'# reference libraries:- #
'# Microsoft ActiveX Data Objects 2.5 or > Library #
'# #
'#########################################################
'You may also need to amend the path to Northwind Database in the connection string below
Const stCon As String = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=D:\a\Excel 2003\archive\Forum\Northwind.mdb;" & _
"Persist Security Info=False"
Private Sub cmdClose_Click()
'close the form
Unload Me
End Sub
Private Sub chkYr_Click()
'This is where you can add a filter by the year
Dim stSQL As String
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim vaData As Variant
'Just select the Distinct Years from Orders Table to load into Year Combobox
stSQL = "SELECT DISTINCT DatePart(""yyyy"",[OrderDate]) FROM ORDERS;"
If chkYr.Value = True Then
'if the year filter checkbox is checked
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
cnt.ConnectionString = stCon
With cnt
.CursorLocation = adUseClient 'Necesary for creating disconnected recordset.
.Open stCon 'Open connection.
'Execute the SQL statement.
Set rst = .Execute(stSQL)
End With
With rst
Set .ActiveConnection = Nothing 'Disconnect the recordset.
'Populate the array with the whole recordset.
vaData = .GetRows
End With
'Close the connection.
cnt.Close
With Me
With .cmbYr
.Clear
'load the query result into combobox
.List = Application.Transpose(vaData)
.ListIndex = -1
End With
End With
Else
With Me
With .cmbYr
.Clear
End With
End With
End If
End Sub
Private Sub cmdQuery_Click()
'run query to find records
Dim stParam As String, stParam2 As String
Dim stSQL As String
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim wsSheet As Worksheet, wbBook As Workbook
Dim i As Long, j As Long, x As Integer
'initial SQL to return all records
stSQL = "SELECT * FROM ORDERS"
'set the parameter strings
stParam = " WHERE DatePart(""yyyy"",[OrderDate]) = " & Me.cmbYr.Text
stParam2 = " ;"
'check & build variable parameters
'depending on whether checkbox ticked by user
If Me.chkYr.Value = True Then
stSQL = stSQL & stParam & stParam2
Else: stSQL = stSQL & stParam2
End If
On Error GoTo ErrHandle
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
Set wbBook = ThisWorkbook
Set wsSheet = ThisWorkbook.Worksheets(1)
With cnt
.ConnectionString = stCon
.Open
End With
With rst
.CursorLocation = adUseClient
.Open stSQL, cnt, adOpenStatic, adLockReadOnly
.ActiveConnection = Nothing 'Here we disconnect the recordset.
j = .Fields.Count
i = .RecordCount
End With
With wsSheet
.UsedRange.Clear
If i = 0 Then GoTo i_Err
'Write the fieldnames to the fifth row in the worksheet
For x = 0 To j - 1
.Cells(5, x + 1).Value = rst.Fields(x).Name
Next x
'Dump the data to the worksheet.
.Cells(6, 1).CopyFromRecordset rst
End With
If CBool(rst.State And adStateOpen) = True Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) = True Then cnt.Close
Set cnt = Nothing
ExitHere:
Exit Sub
ErrHandle:
Dim cnErrors As ADODB.Errors
Dim ErrorItem As ADODB.Error
Dim stError As String
Set cnErrors = cnt.Errors
With Err
stError = stError & vbCrLf & "VBA Error # : " & CStr(.Number)
stError = stError & vbCrLf & "Generated by : " & .Source
stError = stError & vbCrLf & "Description : " & .Description
End With
For Each ErrorItem In cnErrors
With ErrorItem
stError = stError & vbCrLf & "ADO error # : " & CStr(.Number)
stError = stError & vbCrLf & "Description : " & .Description
stError = stError & vbCrLf & "Source : " & .Source
stError = stError & vbCrLf & "SQL State : " & .SqlState
End With
Next ErrorItem
MsgBox stError, vbCritical, "SystemError"
Resume ExitHere
i_Err:
MsgBox "There are no records for this Query"
GoTo ExitHere
End Sub
'#########################################################
'# #
'# References need to be set in the VBE to the following #
'# reference libraries:- #
'# Microsoft ActiveX Data Objects 2.5 or > Library #
'# #
'#########################################################
'You may also need to amend the path to Northwind Database in the connection string below
Const stCon As String = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=D:\a\Excel 2003\archive\Forum\Northwind.mdb;" & _
"Persist Security Info=False"
Private Sub cmdClose_Click()
'close the form
Unload Me
End Sub
Private Sub chkYr_Click()
'This is where you can add a filter by the year
Dim stSQL As String
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim vaData As Variant
'Just select the Distinct Years from Orders Table to load into Year Combobox
stSQL = "SELECT DISTINCT DatePart(""yyyy"",[OrderDate]) FROM ORDERS;"
If chkYr.Value = True Then
'if the year filter checkbox is checked
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
cnt.ConnectionString = stCon
With cnt
.CursorLocation = adUseClient 'Necesary for creating disconnected recordset.
.Open stCon 'Open connection.
'Execute the SQL statement.
Set rst = .Execute(stSQL)
End With
With rst
Set .ActiveConnection = Nothing 'Disconnect the recordset.
'Populate the array with the whole recordset.
vaData = .GetRows
End With
'Close the connection.
cnt.Close
With Me
With .cmbYr
.Clear
'load the query result into combobox
.List = Application.Transpose(vaData)
.ListIndex = -1
End With
End With
Else
With Me
With .cmbYr
.Clear
End With
End With
End If
End Sub
Private Sub cmdQuery_Click()
'run query to find records
Dim stParam As String, stParam2 As String
Dim stSQL As String
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim wsSheet As Worksheet, wbBook As Workbook
Dim i As Long, j As Long, x As Integer
'initial SQL to return all records
stSQL = "SELECT * FROM ORDERS"
'set the parameter strings
stParam = " WHERE DatePart(""yyyy"",[OrderDate]) = " & Me.cmbYr.Text
stParam2 = " ;"
'check & build variable parameters
'depending on whether checkbox ticked by user
If Me.chkYr.Value = True Then
stSQL = stSQL & stParam & stParam2
Else: stSQL = stSQL & stParam2
End If
On Error GoTo ErrHandle
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
Set wbBook = ThisWorkbook
Set wsSheet = ThisWorkbook.Worksheets(1)
With cnt
.ConnectionString = stCon
.Open
End With
With rst
.CursorLocation = adUseClient
.Open stSQL, cnt, adOpenStatic, adLockReadOnly
.ActiveConnection = Nothing 'Here we disconnect the recordset.
j = .Fields.Count
i = .RecordCount
End With
With wsSheet
.UsedRange.Clear
If i = 0 Then GoTo i_Err
'Write the fieldnames to the fifth row in the worksheet
For x = 0 To j - 1
.Cells(5, x + 1).Value = rst.Fields(x).Name
Next x
'Dump the data to the worksheet.
.Cells(6, 1).CopyFromRecordset rst
End With
If CBool(rst.State And adStateOpen) = True Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) = True Then cnt.Close
Set cnt = Nothing
ExitHere:
Exit Sub
ErrHandle:
Dim cnErrors As ADODB.Errors
Dim ErrorItem As ADODB.Error
Dim stError As String
Set cnErrors = cnt.Errors
With Err
stError = stError & vbCrLf & "VBA Error # : " & CStr(.Number)
stError = stError & vbCrLf & "Generated by : " & .Source
stError = stError & vbCrLf & "Description : " & .Description
End With
For Each ErrorItem In cnErrors
With ErrorItem
stError = stError & vbCrLf & "ADO error # : " & CStr(.Number)
stError = stError & vbCrLf & "Description : " & .Description
stError = stError & vbCrLf & "Source : " & .Source
stError = stError & vbCrLf & "SQL State : " & .SqlState
End With
Next ErrorItem
MsgBox stError, vbCritical, "SystemError"
Resume ExitHere
i_Err:
MsgBox "There are no records for this Query"
GoTo ExitHere
End Sub