Copy from: https://softwareengineering.stackexchange.com/questions/158330/cascading-comboboxes
ok so i have a form, in Access 2010, with 1 Textbox and 3 ComboBoxes (1 Enabled & 2 Disabled).
the first ComboBox is not tied to the datasource but is subjective to the other 2 comboboxes. So i handled the Click event for the first Combobox to then make the other 2 enabled, and preload the 2nd ComboBox with a custom RowSource SQL Script dynamically built based on the 1st ComboBox Value.
This all works great for New information but when i goto review the information, via Form, its back to the New mode on the controls.
Question:
What event do i need to handle to check if the current Form Data contains data for the Control Source of the Controls?
As i would express it in Logic (its a mix between C & VB, i know but should get the pt acrossed):
DataSet ds = Form.RowSet
if (ds = Null) then
cbo2.enabled = false
cbo3.enabled = false
else
cbo2.rowsource = "select id, nm from table"
cbo2.value = ds(3)
cbo3.value = ds(4)
end if
... do some other logic ...
Updated Logic - Still problem, cant catch for RecordStatus for some reason (gives 3251 Run-Time Error)
Private Sub Form_Current()
Dim boolnm As Boolean: boolnm = (IsNull(txtName.Value) Or IsEmpty(txtName.Value))
Dim booltype As Boolean: booltype = IsNull(cboType.Value)
Dim boolfamily As Boolean: boolfamily = IsNull(cboType.Value)
Dim boolsize As Boolean: boolsize = IsNull(cboType.Value)
Dim rs As DAO.Recordset: Set rs = Me.Recordset
MsgBox rs.AbsolutePosition
' If rs.RecordStatus = dbRecordNew Then
' MsgBox "New Record being inserted, but not committed yet!", vbOKOnly
' Else
' MsgBox rs(0).Name & " - " & rs(0).Value & vbCrLf & _
' rs(1).Name & " - " & rs(1).Value & vbCrLf & _
' rs(2).Name & " - " & rs(2).Value & vbCrLf & _
' rs(3).Name & " - " & rs(3).Value
' End If
'MsgBox "Name: " & CStr(boolnm) & vbCrLf & _
"Type: " & CStr(booltype) & vbCrLf & _
"Family: " & CStr(boolfamily) & vbCrLf & _
"Size: " & CStr(boolsize), vbOKOnly
End Sub
Here is the final result, with Remou's assistance, and this is only a precursor to the end result (which is out of the context of the question).
Private Sub Form_Current()
If Me.NewRecord Then <=======================
cboType.Value = 0
cboType.Enabled = True
cboFamily.Enabled = False
cboSize.Enabled = False
Else
Dim rs As DAO.Recordset: Set rs = Me.Recordset
'get Family ID
Dim fid As String: fid = rs(2).Value
'Build SQL Query to obtain Type ID
Dim sql As String
sql = "select tid from tblFamily where id = " & fid
'Create Recordset
Dim frs As DAO.Recordset
'Load SQL Script and Execute to obtain Type ID
Set frs = CurrentDb.OpenRecordset(sql, dbOpenDynaset, dbReadOnly)
'Set Type ComboBox Value to Type ID
cboType.Value = frs(0)
cboType_Click 'Simulate Click Event since the Value has changed
'Make sure all 3 Comboboxes are enabled and useable
cboType.Enabled = True
End If
End Sub
Related
All I really need to know is how to make it where I can make selections in multiple multi-select listboxes, but leave any number of them blank and still have the macro/query work without having to put in an error message about it.
This also includes doing the same with the textboxes. The textboxes would function the same as the listboxes where they would search for anything in a data table to matches what I am looking for in the records and display what I am looking for in a table.
Here is my code
Private Sub Command62_Click()
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim varItem As Variant
Dim District As String
Dim Circumstance As String
Dim Location As String
Dim Method As String
Dim Point As String
Dim Rank As String
Dim strSQL As String
Set db = CurrentDb()
Set qdf = db.QueryDefs("qryMultiselect")
For Each varItem In Me!District.ItemsSelected
District = District & ",'" & Me!District.ItemData(varItem) & "'"
Next varItem
If Len(District) = 0 Then
MsgBox "You did not select anything in the Distrcit field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
District = Right(District, Len(District) - 1)
For Each varItem In Me!Circumstance.ItemsSelected
Circumstance = Circumstance & ",'" & Me!Circumstance.ItemData(varItem) &
"'"
Next varItem
If Len(Circumstance) = 0 Then
MsgBox "You did not select anything in the Circumstance field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Circumstance = Right(Circumstance, Len(Circumstance) - 1)
For Each varItem In Me!Location.ItemsSelected
Location = Location & ",'" & Me!Location.ItemData(varItem) & "'"
Next varItem
If Len(Location) = 0 Then
MsgBox "You did not select anything in the Location field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Location = Right(Location, Len(Location) - 1)
For Each varItem In Me!Method.ItemsSelected
Method = Method & ",'" & Me!Method.ItemData(varItem) & "'"
Next varItem
If Len(Method) = 0 Then
MsgBox "You did not select anything in the Method field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Method = Right(Method, Len(Method) - 1)
For Each varItem In Me!Point.ItemsSelected
Point = Point & ",'" & Me!Point.ItemData(varItem) & "'"
Next varItem
If Len(Point) = 0 Then
MsgBox "You did not select anything in the Point field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Point = Right(Point, Len(Point) - 1)
For Each varItem In Me!Rank.ItemsSelected
Rank = Rank & ",'" & Me!Rank.ItemData(varItem) & "'"
Next varItem
If Len(Rank) = 0 Then
MsgBox "You did not select anything in the Rank field." _
, vbExclamation, "Nothing to find!"
Exit Sub
End If
Rank = Right(Rank, Len(Rank) - 1)
strSQL = "SELECT * FROM tblDataEntry " & _"WHERE tblDataEntry.District
IN(" & District & ") AND tblDataEntry.Circumstance IN(" & Circumstance &
") AND tblDataEntry.Location IN(" & Location & ") AND tblDataEntry.Method
IN (" & Method & ") AND tblDataEntry.Point IN (" & Point & ") AND
tblDataEntry.Rank IN(" & Rank & ");"
qdf.SQL = strSQL
DoCmd.OpenQuery "qryMultiselect"
Set db = Nothing
Set qdf = Nothing
End Sub
I still need to add the textboxes, but I'm not sure where. (Please note that I'm still learning VBA).
Firstly, since you are repeatedly performing the same operation for each form control (in this case, constructing a comma-delimited string from the selected items), you can abstract this operation away into a function, and pass such function each List Box function.
For example, you could define a function such as:
Function SelectedItems(objBox As ListBox) As String
Dim strRtn As String, varItm
For Each varItm In objBox.ItemsSelected
strRtn = strRtn & ",'" & objBox.ItemData(varItm) & "'"
Next varItm
If strRtn <> vbNullString Then SelectedItems = Mid(strRtn, 2)
End Function
Which could then be evaluated with a List Box control argument, and would return either a null string ("") or a comma-delimited string of the selected items in the list box, e.g. something like:
?SelectedItems(Forms!Form1!List1)
'A','B'
Furthermore, since your form controls appear to be named consistently relative to the fields in your table, you could further condense your code to something along the following lines:
Private Sub Command62_Click()
Dim strSQL As String
Dim strArr As String
Dim varItm
For Each varItm In Array("District", "Circumstance", "Location", "Method", "Point", "Rank")
strArr = SelectedItems(Me.Controls(varItm))
If strArr <> vbNullString Then
strSQL = strSQL & "t." & varItm & " in (" & strArr & ") and "
End If
Next varItm
If strSQL <> vbNullString Then strSQL = "where " & Left(strSQL, Len(strSQL) - 5)
With CurrentDb.QueryDefs("qryMultiselect")
.SQL = "select * from tblDataEntry t " & strSQL
End With
DoCmd.OpenQuery "qryMultiselect"
End Sub
Note that the above is entirely untested.
Here, the main for each loop iterates over an array of strings corresponding to the names of your form controls and the names of your table fields.
For each form control in this array, the function obtains a comma-delimited string of the selected items in the control, and concatenates this with the existing SQL code only if one or more items have been selected.
As such, if not items are selected, the field will not feature in the SQL where clause.
If any filter has been selected, the trailing five characters (and) are trimmed from the end of the SQL string, and the where keyword is concatenated to the start of the SQL string - this ensures that if no filter has been selected, the resulting SQL code will not include a where clause.
Finally, the SQL for the query definition is updated and the query is opened, per your original code.
Where textboxes are concerned, the task merely need to skip the call to SelectedItems and obtain the value of the textbox directly.
Here is an example incorporating both listboxes & textboxes:
Private Sub Command62_Click()
Dim strSQL As String
Dim strArr As String
Dim varItm
For Each varItm In Array("District", "Circumstance", "Location", "Method", "Point", "Rank")
strArr = vbNullString
Select Case Me.Controls(varItm).ControlType
Case acListBox
strArr = SelectedItems(Me.Controls(varItm))
Case acTextBox
If Not IsNull(Me.Controls(varItm).Value) Then
strArr = "'" & Me.Controls(varItm).Value & "'"
End If
End Select
If strArr <> vbNullString Then
strSQL = strSQL & "t." & varItm & " in (" & strArr & ") and "
End If
Next varItm
If strSQL <> vbNullString Then strSQL = "where " & Left(strSQL, Len(strSQL) - 5)
With CurrentDb.QueryDefs("qryMultiselect")
.SQL = "select * from tblDataEntry t " & strSQL
End With
DoCmd.OpenQuery "qryMultiselect"
End Sub
I hope this helps, but please note that the above is untested and only theory.
I am getting an "Object variable or With block variable not set (Error 91)" error with the following code:
Dim db As Database
Dim rs As Recordset
Private Sub Form_Load()
Dim mySQL As String
mySQL = "SELECT Tuteurs.ID_Tuteur, Tarifs_17_18.*, Paiements_17_18.* " & _
"FROM (Tuteurs INNER JOIN Tarifs_17_18 ON Tuteurs.ID_Tuteur = Tarifs_17_18.TuteurID_Trf) " & _
"INNER JOIN Paiements_17_18 ON Tuteurs.ID_Tuteur = Paiements_17_18.TuteurID_Pmt " & _
"WHERE ID_Tuteur =" & [Forms]![Eleves]![TuteurID_Elv]
Set db = CurrentDb
Set rs = db.OpenRecordset(mySQL, dbOpenDynaset, dbSeeChanges)
rs.MoveFirst
End Sub
Private Sub btn_Enregistrer_Click()
Dim totIns As Integer
totIns = DSum("Montant", "Paiements_17_18", "[Mois_Regle]='Inscription'")
If totIns = rs!Tarif_Inscription Then
MsgBox "Yes" & totIns & " = " & rs!Tarif_Inscription
Else
MsgBox "No" & totIns & " # " & rs!Tarif_Inscription
End If
End Sub
totIns is working very well but rs!Tarif_Inscription is the missing object variable.
[Tarif_Inscription] is a field in the [Tarifs_17_18] Table.
Any Help Please?
I Found the Solution,
My recordset is not in scope and My variables are declared outside My procedure.
Solution found by #Moke123.
In my office of 65 people, I want to create a "portal" for all the employees out of a single .accdb file. It will allow each employee to navigate to a new "screen" from a dropdown menu.
Should I use a single form with plug-and-play subform controls in order to centralize the VBA code, or should I just use different forms?
I'm thinking it would be nice to have one form with plug-and-play subform controls. When the employee selects a new "screen", the VBA just sets the SourceObject property of each subform control and then re-arranges the subforms based on the layout of the selected "screen".
For instance, we currently use a couple of Access database forms to enter and review errors that we find in our workflow system. So in this scenario, to review the errors I would just say
SubForm1.SourceObject = "Form.ErrorCriteria"
SubForm2.SourceObject = "Form.ErrorResults"
And then I would just move them into place (these values would be pulled dynamically based upon the "screen" selected):
SubForm1.Move WindowWidth * 0.05, WindowHeight * 0.05, WindowWidth * 0.9, WindowHeight * 0.2
SubForm2.Move WindowWidth * 0.05, WindowHeight * 0.25, WindowWidth * 0.9, WindowHeight * 0.65
So this creates a small header section (SubForm1) on the form where I can select the criteria for the errors I want to see (data range, which team committed the error, etc) and then I can view the errors in the much larger section below the header (SubForm2) that holds the datasheet with the results.
I can propogate events up to the main form from the ErrorCriteria and ErrorResults forms that are now bound to the subform controls. That will help me to use the basic MVC design pattern for VBA described here. I can treat the main form as the view, even though parts of that view are buried in subform controls. The controller only has to know about that one view.
My problem comes when the user selects a new "screen" from the dropdown menu. I think it would be nice to just re-purpose the subform controls, like so:
SubForm1.SourceObject = "Form.WarehouseCriteria"
SubForm2.SourceObject = "Form.InventoryResults"
And then just move/resize those subforms to the appropriate layout for the "Inventory" screen.
This approach seems to make the user interface design cleaner in my mind because you basically only ever have to deal with one main form that acts as a template and then you plug in the values (the SourceObject properties) into that template.
But each time we change the "screen", we have a totally different "Model" behind the scenes and a new "View" too according to the MVC design pattern. I wonder if that would clutter up the MVC VBA code behind the scenes, or if the VBA code itself could be modularized too (possibly using Interfaces) to make it just as adaptable as the user interface.
What is the cleanest way to do this from both a User Interface perspective, and from a VBA perspective. Use one main form as template where other forms could be swapped in and out as subforms, or just close the current form and open a new form when the user selects a new "screen" from the dropdown menu.
Below is a brief description of one way to 'repurpose' or reformat a form for several uses. Re your question of changing the VBA code, a simple solution would be to check a label value or some value you set in the control, then call the appropriate VBA subroutine.
We had over 100 reports available, each with their own selection criteria/options and we did not want to create a unique filter form for every report. The solution was to identify the selection options available by report, identify the logical order of those options, then create a table that would present the options to the user.
First, we created the table: ctlReportOptions (PK = ID, ReportName, OptionOrder)
Fields: ID (Int), ReportName (text), OptionOrder (Int), ControlName (text), ControlTop (Int), ControlLeft (Int), SkipLabel (Y/N), ControlRecordsourc(text)
Note 1: ID is not an AutoNumber.
Next we populated with records that would define the view the user would see.
Note 2: Using an ID of zero, we created records for EVERY field on the report so we could always redraw for the developers.
Then we created the form and placed controls for every possible filter.
We set the 'Default Value' property to be used as our default.
Some of the controls:
ComboBox to select the report name. Add code for Change event as follows:
Private Sub cboChooseReport_Change()
Dim strSQL As String
Dim rs As ADODB.recordSet
Dim i As Integer
Dim iTop As Integer
Dim iLeft As Integer
Dim iLblTop As Integer
Dim iLblLeft As Integer
Dim iLblWidth As Integer
Dim iTab As Integer
Dim strLabel As String
On Error GoTo Error_Trap
' Select only optional controls (ID <> 0); skip cotrols always present.
strSQL = "SELECT ctlRptOpt.ControlName, 'lbl' & Mid([ControlName],4,99) AS LabelName, SkipLabel " & _
"From ctlRptOpt WHERE (((ctlRptOpt.ID)<>0)) " & _
"GROUP BY ctlRptOpt.ControlName, 'lbl' & Mid([ControlName],4,99), SkipLabel;"
Set rs = New ADODB.recordSet
rs.Open strSQL, CurrentProject.Connection, adOpenDynamic
Do While Not rs.EOF
Me(rs!ControlName).Visible = False ' Hide control
If rs!skiplabel = False Then ' Hide Label if necessary
Me(rs!LabelName).Visible = False
End If
rs.MoveNext
Loop
rs.Close
iTop = 0
iTab = 0
' Get list of controls used by this report; order by desired sequence.
strSQL = "select * from ctlRptOpt " & _
"where [ID] = " & Me.cboChooseReport.Column(3) & _
" order by OptionOrder;"
Set rs = New ADODB.recordSet
rs.Open strSQL, CurrentProject.Connection, adOpenDynamic
If rs.EOF Then ' No options needed
Me.cmdShowQuery.Visible = True
Me.lblReportCriteria.Visible = False
Me.cmdShowQuery.left = 2000
Me.cmdShowQuery.top = 1500
Me.cmdShowQuery.TabIndex = 1
Me.cmdReset.Visible = False
rs.Close
Set rs = Nothing
GoTo Proc_Exit ' Exit
End If
' Setup the display of controls.
Me.lblReportCriteria.Visible = True
Do While Not rs.EOF
If rs!skiplabel = False Then
strLabel = "lbl" & Mid(rs!ControlName, 4)
iLblWidth = Me.Controls(strLabel).Width
Me(strLabel).top = rs!ControlTop
Me(strLabel).left = rs!ControlLeft - (Me(strLabel).Width + 50)
Me(strLabel).Visible = True
End If
iTab = iTab + 1 ' Set new Tab Order for the controls
Me(rs!ControlName).top = rs!ControlTop
Me(rs!ControlName).left = rs!ControlLeft
Me(rs!ControlName).Visible = True
If left(rs!ControlName, 3) <> "lbl" Then
Me(rs!ControlName).TabIndex = iTab
End If
If Me(rs!ControlName).top >= iTop Then
iTop = rs!ControlTop + Me(rs!ControlName).Height ' Save last one
End If
' If not a label and not a 'cmd', it's a filter! Set a default.
If left(rs!ControlName, 3) <> "lbl" And left(rs!ControlName, 3) <> "cmd" Then
If Me(rs!ControlName).DefaultValue = "=""*""" Then
' Me(rs!ControlName) = "*"
ElseIf left(Me(rs!ControlName).DefaultValue, 2) = "=#" And right(Me(rs!ControlName).DefaultValue, 1) = "#" Then
i = Len(Me(rs!ControlName).DefaultValue)
' Me(rs!ControlName) = Mid(Me(rs!ControlName).DefaultValue, 3, i - 3)
ElseIf Me(rs!ControlName).DefaultValue = "True" Then
' Me(rs!ControlName) = True
ElseIf Me(rs!ControlName).DefaultValue = "False" Then
' Me(rs!ControlName) = False
End If
Else
If Me(rs!ControlName).top + Me(rs!ControlName).Height >= iTop Then
iTop = rs!ControlTop + Me(rs!ControlName).Height ' Save last one
End If
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
If Me.cboChooseReport.Column(1) <> "rptInventoryByDate" Then ' It's special
Me.cmdShowQuery.Visible = True
Me.cmdShowQuery.left = 2000
Me.cmdShowQuery.top = iTop + 300
iTab = iTab + 1
Me.cmdShowQuery.TabIndex = iTab
Else
Me.cmdShowQuery.Visible = False
End If
Me.cmdReset.Visible = True
Me.cmdReset.left = 5000
Me.cmdReset.top = iTop + 300
Me.cmdReset.TabIndex = iTab + 1
Proc_Exit:
Exit Sub
Error_Trap:
Err.Source = "Form_frmReportChooser: cboChooseReport_Change at Line: " & Erl
DocAndShowError ' Save error to database for analysis, then display to user.
Resume Proc_Exit ' Exit code.
Resume Next ' All resumption if debugging.
Resume
End Sub
lblReportCriteria: We displayed the final set of filters so when users complained of nothing showing on the report, we asked them to send us a screen print. We also passed this text to the report and it was printed as a footer on the last page.
cmdReset: Reset all controls back to their default values.
cmdShowQuery: Executes the running of the report
Private Sub cmdShowQuery_Click()
Dim qdfDelReport101 As ADODB.Command
Dim qdfAppReport101 As ADODB.Command
Dim qdfDelReport102 As ADODB.Command
Dim qdfAppReport102 As ADODB.Command
Dim qryBase As ADODB.Command
Dim strQueryName As String
Dim strAny_Open_Reports As String
Dim strOpen_Report As String
Dim qdfVendorsInfo As ADODB.Command
Dim rsVendorName As ADODB.recordSet
Dim strVendorName As String
Dim rsrpqFormVendorsInfo As ADODB.recordSet
On Error GoTo Error_Trap
If Not IsNull(Me.cboChooseReport.value) And Me.cboChooseReport.value <> " " Then
strAny_Open_Reports = Any_Open_Reports()
If Len(strAny_Open_Reports) = 0 Then
If Me.cboChooseReport.value = "rptAAA" Then
BuildReportCriteria '
If Me.chkBankBal = True Then
DoCmd.OpenReport "rptAAA_Opt1", acViewPreview
Else
DoCmd.OpenReport "rptAAA_Opt2", acViewPreview
End If
ElseIf Me.cboChooseReport.value = "rptBBB" Then
If IsNull(Me.txtFromDate) Or Not IsDate(Me.txtFromDate) Then
MsgBox "You must enter a valid From Date", vbOKOnly, "Invalid Date"
Exit Sub
End If
If IsNull(Me.txtToDate) Or Not IsDate(Me.txtToDate) Then
MsgBox "You must enter a valid To Date", vbOKOnly, "Invalid Date"
Exit Sub
End If
Me.txtStartDate = Me.txtFromDate
Me.txtEndDate = Me.txtToDate
DoCmd.OpenReport Me.cboChooseReport.value, acViewPreview
ElseIf Me.cboChooseReport.value = "rptCCC" Then
If Me.txtVendorName = "*" Then
gvstr_VendorName = "*"
Else
Set rsVendorName = New ADODB.recordSet
rsVendorName.Open "selVendorName", gv_DBS_Local, adOpenDynamic
Set qdfVendorsInfo = New ADODB.Command
qdfVendorsInfo.ActiveConnection = gv_DBS_SQLServer
qdfVendorsInfo.CommandText = ("qryVendorsInfo")
qdfVendorsInfo.CommandType = adCmdStoredProc
strVendorName = rsVendorName("VendorName")
gvstr_VendorName = strVendorName
End If
DoCmd.OpenReport "rptFormVendorReport", acViewPreview
Else
BuildReportCriteria
If Me.cboChooseReport.value = "rptXXXXXX" Then
ElseIf Me.cboChooseReport.value = "rptyyyy" Then
On Error Resume Next ' All resumption if debugging.
DoCmd.DeleteObject acTable, "temp_xxxx"
On Error GoTo Error_Trap
Set qryBase = New ADODB.Command
qryBase.ActiveConnection = gv_DBS_Local
qryBase.CommandText = ("mtseldata...")
qryBase.CommandType = adCmdStoredProc
qryBase.Execute
End If
DoCmd.Hourglass False
DoCmd.OpenReport Me.cboChooseReport.value, acViewPreview
End If
Else
MsgBox "You cannot open this form/report because you already have a form/report(s) open: " & _
vbCrLf & strAny_Open_Reports & _
vbCrLf & "Please close the open form/report(s) before continuing."
strOpen_Report = Open_Report
DoCmd.SelectObject acReport, strOpen_Report
DoCmd.ShowToolbar "tbForPost"
End If
Else
MsgBox "Please Choose Report", vbExclamation, "Choose Report"
End If
Exit Sub
Error_Trap:
Err.Source = "Form_frmReportChooser: cmdShowQuery_Click - Report: " & Nz(Me.cboChooseReport.value) & " at Line: " & Erl
If Err.Number = 2501 Then ' MsgBox "You chose not to open this report.", vbOKOnly, "Report cancelled"
Exit Sub
ElseIf Err.Number = 0 Or Err.Number = 7874 Then
Resume Next ' All resumption if debugging.
ElseIf Err.Number = 3146 Then ' ODBC -- call failed -- can have multiple errors
Dim errLoop As Error
Dim strError As String
Dim Errs1 As Errors
' Enumerate Errors collection and display properties of each Error object.
i = 1
Set Errs1 = gv_DBS_SQLServer.Errors
Err.Description = Err.Description & "; Err.Count = " & gv_DBS_SQLServer.Errors.Count & "; "
For Each errLoop In Errs1
With errLoop
Err.Description = Err.Description & "Error #" & i & ":" & " ADO Error#" & .Number & _
" Description= " & .Description
i = i + 1
End With
Next
End If
DocAndShowError ' Save error to database for analysis, then display to user.
Exit Sub
Resume Next ' All resumption if debugging.
Resume
End Sub
Function to build a string showing all of the selection criteria:
Function BuildReportCriteria()
Dim frmMe As Form
Dim ctlEach As Control
Dim strCriteria As String
Dim prp As Property
Dim strSQL As String
Dim rs As ADODB.recordSet
On Error GoTo Error_Trap
strSQL = "select * from ctlRptOpt " & _
"where ID = " & Me.cboChooseReport.Column(3) & _
" order by OptionOrder;"
Set rs = New ADODB.recordSet
rs.Open strSQL, CurrentProject.Connection, adOpenDynamic
If rs.EOF Then
strCriteria = " Report Criteria: None"
Else
strCriteria = " Report Criteria: "
End If
Do While Not rs.EOF
Set ctlEach = Me.Controls(rs!ControlName)
If ctlEach.ControlType = acTextBox Or ctlEach.ControlType = acComboBox Then
If ctlEach.value <> "*" And ctlEach.Name <> "cboChooseReport" And ctlEach.Name <> "cboLocCountry" Then
strCriteria = strCriteria & ctlEach.Tag & " = " & ctlEach.value & " , "
End If
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
If Me.chkOblBal = -1 Then
strCriteria = strCriteria & "Non-zero balances only = Yes"
Else
'return string with all choosen criteria and remove last " , " from the end of string
strCriteria = left$(strCriteria, Len(strCriteria) - 3)
End If
fvstr_ReportCriteria = strCriteria
Set ctlEach = Nothing
Exit Function
Error_Trap:
If Err.Number = 2447 Then
Resume Next ' All resumption if debugging.
End If
Err.Source = "Form_frmReportChooser: BuildReportCriteria at Line: " & Erl
DocAndShowError ' Save error to database for analysis, then display to user.
Exit Function
Resume Next ' All resumption if debugging.
End Function
Finally, each report had it's own query that would filter based on the values in the controls on this form.
Hope this helps. If you are curious about any of the weird things you see, let me know. (i.e. we always used line numbers in the code (I deleted before posting) that allowed us to identify exact line where code fails)
I've been looking a while now for a solution to export a query with open parameters. I need to export a Query as a Formatted Excel Spreadsheet and can't create additional Tables, Queries, Forms, or Reports to the Database being used. I use DoCmd.OutputTo as it exports a formatted query unlike DoCmd.TransferSpreadsheet however I can't seem to export the query with defined parameters. I need to include the parameters or else the user will be forced to input the start and end date three times a piece as the database for some reason asks for the startDate and endDate twice and in order to keep the excel spreadsheet and the subsequent outlook section consistant i would have to ask the user to input their previous parameters again
Sub Main()
On Error GoTo Main_Err
'Visually Display Process
DoCmd.Hourglass True
Dim fpath As String
Dim tname As String
Dim cname As String
Dim tType As AcOutputObjectType
Dim tempB As Boolean
fpath = CurrentProject.path & "\"
'tType = acOutputTable
'tname = "APPROVED SWPS FOR LOOK AHEAD & BAR CHART"
tType = acOutputQuery
tname = "ASFLA&BC Query"
cname = "Temp BPC Calendar"
Dim qdfQry As DAO.QueryDef
Dim strStart As String
Dim strEnd As String
Set qdfQry = CurrentDb().QueryDefs(tname)
'strStart = InputBox("Please enter Start date (mm/dd/yyyy)")
'strEnd = InputBox("Please enter Start date (mm/dd/yyyy)")
qdfQry.Parameters("ENTER START DATE") = FormatDateTime("6/30/12", vbShortDate) 'strEnd
qdfQry.Parameters("ENTER END DATE") = FormatDateTime("7/1/12", vbShortDate) 'strStart
tempB = Backup(fpath, qdfQry, tType)
If (Not tempB) Then
MsgBox "Excel Conversion Ended Prematurely..."
Exit Sub
End If
' tempB = sendToOutlook(qdfQry, cname)
' If (Not tempB) Then
' MsgBox "Access Conversion Ended Prematurely..."
' Exit Sub
' End If
MsgBox "Procedure Completed Successfully"
Main_Exit:
DoCmd.Hourglass False
Exit Sub
Main_Err:
DoCmd.Beep
MsgBox Error$
Resume Main_Exit
End Sub
'************************************************************************************
'*
'* Excel PORTION
'*
'************************************************************************************
Public Function Backup(path As String, db As DAO.QueryDef, Optional outputType As AcOutputObjectType) As Boolean
On Error GoTo Error_Handler
Backup = False
Dim outputFileName As String
Dim name As String
Dim tempB As Boolean
'Set Up All Name Variablesand
name = Format(Date, "MM-dd-yy") & ".xls"
'Cleans Directory of Any older files and places them in an archive
SearchDirectory path, "??-??-??.xls", name
'See If File Can Now Be Exported. If Already Exists ask to overwrite
outputFileName = path & name
tempB = OverWriteRequest(outputFileName)
If tempB Then
'Formats The Table And Exports Into A Formatted SpreadSheet
'Checks if an output type was added to the parameter if not defualt to table
If Not IsMissing(outputType) Then
DoCmd.OutputTo outputType, db.name, acFormatXLS, outputFileName, False
Else
DoCmd.OutputTo acOutputTable, db.name, acFormatXLS, outputFileName, False
End If
Else
Exit Function
End If
Backup = True
Error_Handler_Exit:
Exit Function
Error_Handler:
MsgBox "MS Access has generated the following error" & vbCrLf & vbCrLf & "Error Number: " & _
Err.number & vbCrLf & "Error Source: Main Excel Backup" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
The SQL currently given looks like similar to below with omitted fields for for clarity
PARAMETERS [ENTER START DATE] DateTime, [ENTER END DATE] DateTime;
SELECT [SWPS].STATION,
[SWPS].START_DATE,
[SWPS].END_DATE,
FROM [SWPS]
WHERE ((([SWPS].STATION)
Like ("*"))
AND (([SWPS].START_DATE)<=[ENTER END DATE])
AND (([SWPS].END_DATE)>=[ENTER START DATE])
AND (([SWPS].SWP_STATUS) In ("A","P","W","T","R")));
I suggest you change the sql of the query.
Dim qdfQry As DAO.QueryDef
Dim strStart As String
Dim strEnd As String
''You could use a query specifically for this
Set qdfQry = CurrentDb.QueryDefs(tname)
sSQL=qdfQry.SQL
NewSQL = "SELECT [SWPS].STATION, [SWPS].START_DATE, [SWPS].END_DATE, " _
& "FROM [SWPS] WHERE [SWPS].STATION Like '*' " _
& "AND [SWPS].SWP_STATUS In ('A','P','W','T','R') " _
& "AND [SWPS].START_DATE)<=#" & Format(DateStart, "yyyy/mm/dd") & "# " _
& "AND [SWPS].END_DATE)>=#" & Format(DateEnd, "yyyy/mm/dd") & "#"
qdfQry.SQL = NewSQL
''Do the excel stuff
''Reset the query
qdfQry.SQL = sSQL
I'm writing an Access database. I have a number of forms that are identical. These are used to edit look up lists for different fields in my main contacts table.
e.g. there is a company field and a country field. The forms that open for each editable list are identical with repeat vba code in each becasue I cannot work out how to reference the active table from the active form.
The code I currently have for clearing all the yes/no boxes in the table is:
Private Sub cmdClearTicks_Click()
Dim db As Database
' Dim sel As Control
Set db = CurrentDb
' Clear all ticks of selected records
db.Execute "UPDATE ContactCompany " _
& "SET Selected = null "
' Update Selected Field
Me.Requery
End Sub
ContactCompany is the name of the table. I would like to be able to set this sub globally but cannot work out what I should replace ContactCompany with to reference the table in the currently open form. I've already tried Me.RecordSource which does not work.
I'm very grateful for what I assume is a very easy fix!
Sean posted a great fix below. I'm now stumped with including a filter too and defining it globaly.
Sub SelectFiltered(RS As String)
Dim strFilter As String
Dim strSQl As String
If InStr(RS, "FROM") Then
RS = Mid(RS, InStr(RS, "FROM") + 5)
If InStr(RS, " ") Then RS = Left(RS, InStr(RS, " ") - 1)
End If
strFilter = Me.Filter
If Me.FilterOn = False Then
'Select Case MsgBox("No search or filter applied.", vbCritical + vbOKOnly, "Warning")
'End Select
strSQl = "UPDATE " & RS & " " & _
"SET Selected = 1 "
Else
strSQl = "UPDATE " & RS & " " & _
"SET Selected = 1 " & _
"WHERE " & strFilter
End If
DoCmd.SetWarnings False
DoCmd.RunSQL strSQl
DoCmd.SetWarnings True
End Sub
Me.filter doesn't work in the global sub. Sean - I'm sure you'll have an answer for this in a sec. Thanks again!
you are close with using Me.Recordsource
db.Execute "UPDATE " & Me.Recordsource & " SET Selected = null "
or, if you want it as a global function, pass Me.Recordsource to it
Sub ClearTicks(RS as string,StrFilter as string)
Dim db As Database
Set db = CurrentDb
If InStr(RS, "FROM") Then
RS = Mid(RS, InStr(RS, "FROM") + 5)
If InStr(RS, " ") Then RS = Left(RS, InStr(RS, " ") - 1)
End If
' Clear all ticks of selected records
db.Execute "UPDATE " & RS & " SET Selected = null "
If StrFilter="" then 'no filter
Else 'filter
End If
End Sub
and your calling function would be:
Private Sub cmdClearTicks_Click()
ClearTicks Me.Recordsource,Me.Filter
Me.Refresh
End Sub
If you want a more reusable function method that could be expanded more easily, then call the sub/function with Me.Name as the parameter (e.g. MySub Me.Name) and then in your reusable function:
sub MySub(FrmName as string)
Forms(FrmName).Filter
Forms(FrmName).Recordsource
Forms(FrmName).AnyOtherParamater