Option Compare Database
Option Explicit
Private Sub Form_Open(Cancel As Integer)
'load the combo boxes with possible months
Call LoadComboBoxes
'set the combo boxes, check boxes, and text fields to locked
'until the specific group button is pressed
Me.PresetTimePeriod_CmBox_2007.Locked = True
Me.PresetTimePeriod_CmBox_2008.Locked = True
Me.PresetTimePeriod_CmBox_2009.Locked = True
Me.FromMonth.Locked = True
Me.FromYear.Locked = True
Me.ToMonth.Locked = True
Me.ToYear.Locked = True
Me.Large_Criteria_Time_Period.Locked = True
Me.Medium_Criteria_Time_Period.Locked = True
Me.Small_Criteria_Time_Period.Locked = True
Me.Other_Criteria_Time_Period.Locked = True
Me.TxBox_Other_Min.Locked = True
Me.TxBox_Other_Max.Locked = True
End Sub
Function LoadComboBoxes()
'used to load the fromMonth FromYear ToMonth ToYear
'combo boxes based on the table data
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As Field
Dim dteTemp As Date
Dim strQtr As String
Dim blnFound As Boolean
Dim strTblName As String
Dim strCreateSQL As String
Dim strWriteSQL As String
'create a temporary table which will hold all available data for the combo boxes
'this data is created based on the masterdata field names
strTblName = "tmptblComboBoxData"
Call EraseTable(strTblName)
'this statement create the needed sql to create the table
strCreateSQL = "CREATE TABLE " & strTblName & " (" & _
"FieldName TEXT(25), " & _
"FieldDate Date, " & _
"FieldMonth Integer, " & _
"FieldYear Integer, " & _
"FieldQtr TEXT(25))"
CurrentDb.Execute (strCreateSQL)
strTblName = "MasterData"
'cycle through all the fields in the strTblName (MasterData) table to create the needed
'data for the combo boxes
Set db = CurrentDb
Set tbl = db.TableDefs(strTblName)
For Each fld In tbl.Fields
'if the field name is a valid date
If IsDate(Left(fld.Name, 2) & "-01-" & _
Right(fld.Name, 2)) = True Then
'assigne the combined value to a variable for use
'data format is assumed <Month><YEAR> with leading zero (0107,0207,0307...)
dteTemp = DateValue(Left(fld.Name, 2) & "-01-" & _
Right(fld.Name, 2))
'establish which quarter the date ends up in.
'assumes fiscal year starts in jan
Select Case Month(dteTemp)
Case 1, 2, 3
strQtr = "1Q " & Year(dteTemp)
Case 4, 5, 6
strQtr = "2Q " & Year(dteTemp)
Case 7, 8, 9
strQtr = "3Q " & Year(dteTemp)
Case 10, 11, 12
strQtr = "4Q " & Year(dteTemp)
End Select
'create the needed sql to append the data to the temporary table
strWriteSQL = "INSERT INTO tmptblComboBoxData ( FieldName, FieldDate, FieldMonth, FieldYear, FieldQtr ) " & _
"SELECT '" & fld.Name & _
"', #" & dteTemp & _
"#, " & Left(fld.Name, 2) & _
", " & Right(fld.Name, 2) & _
", '" & strQtr & "';"
CurrentDb.Execute (strWriteSQL)
End If
Next fld
End Function
Private Sub Preview_Cstm_Rpt_Btn_Click()
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim frm As Form
Dim ctl As Control
Dim ctlTmp As Control
Dim prp As Property
Dim varItm As Variant
Dim strTblName As String
Dim strSelectSQL As String
Dim strWhereSQL As String
Dim strSQL As String
Dim dteStart As Date
Dim dteEnd As Date
'set up a sub routine to ensure the user has filled in the needed
'fields to execute the query builder
If blnCheckForm = True Then
'these variables will be used to help establish the sql statement
strTblName = "MasterData"
strSelectSQL = "SELECT "
strWhereSQL = "WHERE "
strSQL = "FROM " & strTblName & " "
'set the value of the form with the correct form name
Set frm = Forms![CRA_rpt_bldr_custom1]
'cycle through each control on the form
For Each ctl In frm.Controls
'find the specific control which is an option button. Each of the groups
'have an option button that must be pressed to get to the needed criteria
If ctl.Properties("ControlType") = acOptionButton Then
'some of the option buttons are not fields to add to the sql but are only
'group headings. if the control name does not start with OB then it
'is not a field to be added only a group heading
If ctl.Value = True And Left(ctl.Name, 2) = "OB" Then
'add the found control to the select statement
Call BuildSelect(strSelectSQL, ctl)
'add the found controls to the where statement
Call BuildWhere(strWhereSQL, frm, ctl)
Else
'if the custom time period is selected
If ctl.Name = "CustomTimePeriod" And ctl.Value = True Then
dteStart = DateValue(Me.FromMonth & "-1-" & Me.FromYear)
dteEnd = DateValue(Me.ToMonth & "-1-" & Me.ToYear)
'then add the needed field names to the select and where statement
Call GetFieldNames(strTblName, strSelectSQL, strWhereSQL, dteStart, _
dteEnd, frm, GetCriteriaValue(frm))
End If
'if the preset time period is selected
If ctl.Name = "PresetTimePeriod" And ctl.Value = True Then
'cycle through the controls on the form again to find the right ones
For Each ctlTmp In frm.Controls
'if the control matches then pull then
If Left(ctlTmp.Name, Len(ctl.Name)) = ctl.Name And ctlTmp.Name <> ctl.Name Then
If Nz(ctlTmp.Column(0)) <> "" Then
'populate the needed variables to get the field names and criteria
dteStart = DateValue(ctlTmp.Column(1))
dteEnd = DateValue(ctlTmp.Column(2))
'then add the needed field names to the select and where statement
Call GetFieldNames(strTblName, strSelectSQL, strWhereSQL, dteStart, _
dteEnd, frm, GetCriteriaValue(frm))
End If
End If
Next ctlTmp
End If
End If
End If
Next ctl
'make sure something was selected and clean up the select statement
If Len(strSelectSQL) > 7 Then
strSelectSQL = Left(strSelectSQL, Len(strSelectSQL) - 2) & " "
Else
strSelectSQL = strSelectSQL & "* "
End If
strSQL = strSelectSQL & strSQL
'make sure something was selected and clean up the where statement
If Len(strWhereSQL) > 8 Then
strSQL = strSQL & Left(strWhereSQL, Len(strWhereSQL) - 5) & ";"
Else
strSQL = Left(strSQL, Len(strSQL) - 1) & ";"
End If
End If
Debug.Print strSQL
Set db = CurrentDb
EraseQuery ("tmpqrySQLBuilder")
db.CreateQueryDef "tmpqrySQLBuilder", strSQL
DoCmd.OpenQuery "tmpqrySQLBuilder"
End Sub
Function GetCriteriaValue(frm As Form) As String
'this function is used to find the correct criteria based on the user
'input from the by classifications section of the form
'the definitions of the size is stored in the tblClassificationsDefined table
Dim ctlTemp As Control
Dim blnFound As Boolean
Dim rsRead As DAO.Recordset
Dim strReadSQL As String
'loop through all the controls to find the correct set of check boxes
For Each ctlTemp In frm.Controls
'if the control matches the criteria_time_period
If Right(ctlTemp.Properties("Name"), 20) = "Criteria_Time_Period" Then
'if the control is selected
If ctlTemp.Value = True Then
'this sql statement gets the data for the specific size client the user choose
strReadSQL = "SELECT tblClassificationsDefined.* " & _
"FROM tblClassificationsDefined " & _
"WHERE (((tblClassificationsDefined.CName)='" & _
ctlTemp.Properties("Name") & "'));"
'this statement establishes a record set in memory which can be gone through
'using this code below. this recordset can be manipulated as well (though this is not)
Set rsRead = CurrentDb.OpenRecordset(strReadSQL)
'make sure something was returned in the sql statement
If rsRead.RecordCount > 0 Then
'these if statements are set up based on the way the table is established
'if the lower bound of the criteria is not blank
If Nz(rsRead("CNumberSmall")) <> "" Then
'if the upper bound of the criteria is not blank
If Nz(rsRead("CNumberBig")) <> "" Then
'the code assumes the criteria is between the upper and lower
GetCriteriaValue = "Between " & rsRead("CNumberSmall") & _
" AND " & rsRead("CNumberBig")
Else
'if the upper bound is blank
'the code assumes the criteria is greather or equal to the small number
GetCriteriaValue = ">= " & rsRead("CNumberSmall")
End If
Else
'if the lowe bound is blank and
'if the upper bound of the criteria is not blank
If Nz(rsRead("CNumberBig")) <> "" Then
'the code assumes the criteria is less than or equal to the big number
GetCriteriaValue = "<= " & rsRead("CNumberBig")
Else
'if both boxes are empty something is wrong
MsgBox "Sorry, nothing found to match selected criteria in the tblClassificationsDefined table", vbCritical
End If
End If
Else ' check to see if the user selected other values
If Left(ctlTemp.Properties("Name"), 5) = "Other" Then
GetCriteriaValue = "Between " & Me.TxBox_Other_Min & _
" AND " & Me.TxBox_Other_Max
Else
'if both boxes are empty something is wrong
MsgBox "Sorry, nothing found to match selected criteria in the tblClassificationsDefined table", vbCritical
End If
End If
rsRead.Close
End If
End If
Next ctlTemp
End Function
Function GetFieldNames(strTblName As String, strSelectSQL As String, strWhereSQL As String, dteStart As Date, dteEnd As Date, frm As Form, strValue As String)
'this function goes through the strTblName and looks for any field
'which will qualify as a date field
Dim db As DAO.Database
Dim tbl As DAO.TableDef
Dim fld As Field
Dim dteTemp As Date
Dim blnFound As Boolean
blnFound = False
'add the needed open perethecies to the sql
strWhereSQL = strWhereSQL & "("
'establish the variables need to access the fields collection
Set db = CurrentDb
Set tbl = db.TableDefs(strTblName)
'establish a loop through the fields of this table strTblName
For Each fld In tbl.Fields
'if the field falls into the criteria of a date then <month><Year> with leading zero (0107,0207,0307...)
If IsDate(Left(fld.Name, 2) & "-01-" & Right(fld.Name, 2)) = True Then
'assigne the field name a real date based on the first day of the month
dteTemp = DateValue(Left(fld.Name, 2) & "-01-" & _
Right(fld.Name, 2))
'if the field name real date falls equal to or between the passed in start and dend date then
If dteTemp >= dteStart And dteTemp <= dteEnd Then
'build the segment for the select statement
Call BuildSelectTimePeriod(strSelectSQL, fld.Name)
'build the segment for the where statement
Call BuildWhereTimePeriod(strWhereSQL, frm, fld, strValue)
blnFound = True
End If
End If
Next fld
'clean up the sql as needed
If blnFound = True Then
strWhereSQL = Left(strWhereSQL, Len(strWhereSQL) - 4) & ") AND "
Else
strWhereSQL = Left(strWhereSQL, Len(strWhereSQL) - 1)
End If
End Function
Function BuildSelectTimePeriod(strSQL As String, strVal As String)
'used to build the required select portion of the sql statement for the time
'period specific fields
strSQL = strSQL & "[" & strVal & "], "
End Function
Function BuildWhereTimePeriod(strSQL As String, frm As Form, fld As Field, strValue As String)
'used to build the required where segment for the sql statement for the time
'period specific fields
strSQL = strSQL & "[" & fld.Name & "] " & strValue & _
" AND " 'by changing this and to an or the query is changed from each fielding matching to
'criteria to any field matching the criteria
End Function
Function BuildSelect(strSQL As String, ctl As Control)
'used to build the required select portion of the sql statement
strSQL = strSQL & "[" & Mid(ctl.Name, 4, Len(ctl.Name) - 3) & "], "
End Function
Function BuildWhere(strSQL As String, frm As Form, ctl As Control)
'used to build the required where segment for the sql statement
Dim ctlTemp As Control
Dim blnFound As Boolean
blnFound = False
strSQL = strSQL & "("
'loop through all the controls to find the correct set of check boxes
For Each ctlTemp In frm.Controls
'make sure the criteria selections on the form are check boxes and name correctly
If ctlTemp.Properties("ControlType") = acCheckBox Then
'if the control name contains an under score continue
If InStr(1, ctlTemp.Properties("name"), "_") > 0 Then
'if the first part of the control is named the same as the group name continue
If Left(ctlTemp.Properties("name"), InStr(1, ctlTemp.Properties("name"), "_") - 1) _
= Mid(ctl.Name, 4, Len(ctl.Name) - 3) Then
'if the correct control is checked then add it to the where clause
If ctlTemp.Value = True Then
strSQL = strSQL & "[" & Left(ctlTemp.Name, InStr(1, ctlTemp.Name, "_") - 1) & _
"] = '" & Right(ctlTemp.Name, Len(ctlTemp.Name) - InStrRev(ctlTemp.Name, "_")) & "' OR "
blnFound = True
End If
End If
End If
End If
Next ctlTemp
'clean up the sql as needed
If blnFound = True Then
strSQL = Left(strSQL, Len(strSQL) - 4) & ") AND "
Else
strSQL = Left(strSQL, Len(strSQL) - 1)
End If
End Function
Function blnCheckForm() As Boolean
'write code to ensure the user has entered all the data needed to run the sql builder
'specificly make sure the time period has four valid entries.
blnCheckForm = True
End Function
Private Sub Hierarchy_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.Hierarchy = True Then
Me.OB_UltP_Name.Locked = False
Me.OB_Cust_Name.Locked = False
Me.OB_CAS_ACCT_NUMBER.Locked = False
Me.OB_UltP_Name = False
Me.OB_Cust_Name = False
Me.OB_CAS_ACCT_NUMBER = False
Else
Me.OB_UltP_Name.Locked = True
Me.OB_Cust_Name.Locked = True
Me.OB_CAS_ACCT_NUMBER.Locked = True
Me.OB_UltP_Name = Null
Me.OB_Cust_Name = Null
Me.OB_CAS_ACCT_NUMBER = Null
End If
End Sub
Private Sub CustomTimePeriod_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.CustomTimePeriod = True Then
Me.FromMonth.Locked = False
Me.FromMonth = ""
Me.FromYear.Locked = False
Me.FromYear = ""
Me.ToMonth.Locked = False
Me.ToMonth = ""
Me.ToYear.Locked = False
Me.ToYear = ""
Me.PresetTimePeriod = False
Call PresetTimePeriod_AfterUpdate
Me.Large_Criteria_Time_Period.Locked = False
Me.Large_Criteria_Time_Period = False
Me.Medium_Criteria_Time_Period.Locked = False
Me.Medium_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period.Locked = False
Me.Small_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period.Locked = False
Me.Other_Criteria_Time_Period = False
Else
Me.FromMonth.Locked = True
Me.FromMonth = ""
Me.FromYear.Locked = True
Me.FromYear = ""
Me.ToMonth.Locked = True
Me.ToMonth = ""
Me.ToYear.Locked = True
Me.ToYear = ""
Me.Large_Criteria_Time_Period.Locked = True
Me.Large_Criteria_Time_Period = False
Me.Medium_Criteria_Time_Period.Locked = True
Me.Medium_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period.Locked = True
Me.Small_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period.Locked = True
Me.Other_Criteria_Time_Period = False
End If
End Sub
Private Sub PresetTimePeriod_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.PresetTimePeriod = True Then
Me.PresetTimePeriod_CmBox_2007.Locked = False
Me.PresetTimePeriod_CmBox_2007 = ""
Me.PresetTimePeriod_CmBox_2008.Locked = False
Me.PresetTimePeriod_CmBox_2008 = ""
Me.PresetTimePeriod_CmBox_2009.Locked = False
Me.PresetTimePeriod_CmBox_2009 = ""
Me.CustomTimePeriod = False
Call CustomTimePeriod_AfterUpdate
Me.Large_Criteria_Time_Period.Locked = False
Me.Large_Criteria_Time_Period = False
Me.Medium_Criteria_Time_Period.Locked = False
Me.Medium_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period.Locked = False
Me.Small_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period.Locked = False
Me.Other_Criteria_Time_Period = False
Else
Me.PresetTimePeriod_CmBox_2007.Locked = True
Me.PresetTimePeriod_CmBox_2007 = ""
Me.PresetTimePeriod_CmBox_2008.Locked = True
Me.PresetTimePeriod_CmBox_2008 = ""
Me.PresetTimePeriod_CmBox_2009.Locked = True
Me.PresetTimePeriod_CmBox_2009 = ""
Me.Large_Criteria_Time_Period.Locked = True
Me.Large_Criteria_Time_Period = False
Me.Medium_Criteria_Time_Period.Locked = True
Me.Medium_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period.Locked = True
Me.Small_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period.Locked = True
Me.Other_Criteria_Time_Period = False
End If
End Sub
Private Sub ToMonth_AfterUpdate()
'make sure the date values selected by the user are correct
If Nz(Me.ToMonth) <> "" And Nz(Me.ToYear) <> "" And Nz(Me.FromMonth) <> "" And _
Nz(Me.FromYear) <> "" Then
'make sure the from date is less than or equal to the to date
If DateValue("01-" & Me.ToMonth & "-" & Me.ToYear) < DateValue("01-" & Me.FromMonth & _
"-" & Me.FromYear) Then
MsgBox "To date selection must be later or equal to from date.", vbCritical
End If
End If
End Sub
Private Sub ToYear_AfterUpdate()
'make sure the date values selected by the user are correct
If Nz(Me.ToMonth) <> "" And Nz(Me.ToYear) <> "" And Nz(Me.FromMonth) <> "" And _
Nz(Me.FromYear) <> "" Then
'make sure the from date is less than or equal to the to date
If DateValue("01-" & Me.ToMonth & "-" & Me.ToYear) < DateValue("01-" & Me.FromMonth & _
"-" & Me.FromYear) Then
MsgBox "To date selection must be later or equal to from date.", vbCritical
End If
End If
End Sub
Private Sub FromMonth_AfterUpdate()
'make sure the date values selected by the user are correct
If Nz(Me.FromMonth) <> "" And Nz(Me.FromYear) <> "" And Nz(Me.FromMonth) <> "" And _
Nz(Me.FromYear) <> "" Then
'make sure the from date is less than or equal to the to date
If DateValue("01-" & Me.FromMonth & "-" & Me.FromYear) < DateValue("01-" & Me.FromMonth & _
"-" & Me.FromYear) Then
MsgBox "From date selection must be later or equal From from date.", vbCritical
End If
End If
End Sub
Private Sub FromYear_AfterUpdate()
'make sure the date values selected by the user are correct
If Nz(Me.FromMonth) <> "" And Nz(Me.FromYear) <> "" And Nz(Me.FromMonth) <> "" And _
Nz(Me.FromYear) <> "" Then
'make sure the from date is less than or equal to the to date
If DateValue("01-" & Me.FromMonth & "-" & Me.FromYear) < DateValue("01-" & Me.FromMonth & _
"-" & Me.FromYear) Then
MsgBox "From date selection must be later or equal From from date.", vbCritical
End If
End If
End Sub
Private Sub Large_Criteria_Time_Period_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.Large_Criteria_Time_Period = True Then
Me.Medium_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period = False
Call Other_Criteria_Time_Period_AfterUpdate
End If
End Sub
Private Sub Medium_Criteria_Time_Period_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.Medium_Criteria_Time_Period = True Then
Me.Large_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period = False
Call Other_Criteria_Time_Period_AfterUpdate
End If
End Sub
Private Sub Small_Criteria_Time_Period_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.Small_Criteria_Time_Period = True Then
Me.Large_Criteria_Time_Period = False
Me.Medium_Criteria_Time_Period = False
Me.Other_Criteria_Time_Period = False
Call Other_Criteria_Time_Period_AfterUpdate
End If
End Sub
Private Sub Other_Criteria_Time_Period_AfterUpdate()
'lock the needed controls so the user can not select them without the group
If Me.Other_Criteria_Time_Period = True Then
Me.Large_Criteria_Time_Period = False
Me.Medium_Criteria_Time_Period = False
Me.Small_Criteria_Time_Period = False
Me.TxBox_Other_Max.Locked = False
Me.TxBox_Other_Max = ""
Me.TxBox_Other_Min.Locked = False
Me.TxBox_Other_Min = ""
Else
Me.TxBox_Other_Max.Locked = True
Me.TxBox_Other_Max = ""
Me.TxBox_Other_Min.Locked = True
Me.TxBox_Other_Min = ""
End If
End Sub
Private Sub OB_Sub_Prod_Name_AfterUpdate()
'used to lock the check boxes for this group
If Me.OB_Sub_Prod_Name = True Then
Call LockControls(Me.Form, "Sub Prod Name", False)
Else
Call LockControls(Me.Form, "Sub Prod Name", True)
End If
End Sub
Private Sub OB_UltP_Geo_Region_Code_AfterUpdate()
'used to lock the check boxes for this group
If Me.OB_UltP_Geo_Region_Code = True Then
Call LockControls(Me.Form, "UltP Geo Region Code", False)
Else
Call LockControls(Me.Form, "UltP Geo Region Code", True)
End If
End Sub
Private Sub OB_UltP_Segment_AfterUpdate()
'used to lock the check boxes for this group
If Me.OB_UltP_Segment = True Then
Call LockControls(Me.Form, "UltP Segment", False)
Else
Call LockControls(Me.Form, "UltP Segment", True)
End If
End Sub
Function LockControls(frm As Form, strCtlName As String, blnValue As Boolean)
'lock or unlock all controls passed through
Dim ctl As Control
'cycle through each control on the form
For Each ctl In frm.Controls
If Left(ctl.Properties(1), Len(strCtlName)) = strCtlName Then
ctl.Locked = blnValue
ctl = False
End If
Next ctl
End Function
Function EraseTable(TableName As String)
'Delete the table specified
If CheckTable(TableName) = True Then DoCmd.DeleteObject acTable, TableName
End Function
Function CheckTable(TableName As String) As Boolean
On Error GoTo subexit:
If CurrentDb.TableDefs(TableName).Name = TableName Then
CheckTable = True
End If
subexit:
End Function
Function EraseQuery(QueryName As String)
'Delete the Query specified
If CheckQuery(QueryName) = True Then DoCmd.DeleteObject acQuery, QueryName
End Function
Function CheckQuery(QueryName As String) As Boolean
On Error GoTo subexit:
If CurrentDb.QueryDefs(QueryName).Name = QueryName Then
CheckQuery = True
End If
subexit:
End Function
'create the needed sql to append the data to the temporary table
strWriteSQL = "INSERT INTO tmptblComboBoxData ( FieldName, FieldDate, FieldMonth, FieldYear, FieldQtr ) " & _
"SELECT '" & fld.Name & _
"', #" & dteTemp & _
"#, " & Left(fld.Name, 2) & _
", " & Right(fld.Name, 2) & _
", '" & strQtr & "';"
CurrentDb.Execute (strWriteSQL)
How to use the query by form (QBF) technique in Microsoft Access
http://support.microsoft.com/default.aspx?scid=kb;en-us;304428