I'm working with MS Access 2007. I have an event mapped to a command button, which works as expected when it's clicked. I've also added an ampersand in the caption field for the button command, so users can use shortcut keys (in this case alt+s) to also fire the event.
Here is the command that's executed when the command button is clicked or, depending on which fields are in focus, alt+s is pressed:
Private Sub cmdSearch_Click()
If cmdSearch.Caption = "&Search Mode" Then
cmdDelete.Enabled = False
cmdGotoNew.Enabled = False
cmdMenu.Enabled = False
cmdLicHistory.Enabled = False
cmdComplaints.Enabled = False
cmdAddPrint.Enabled = False
cmdReceipts.Enabled = False
cmdLicensee.Enabled = False
cmdSearch.Caption = "Run &Search"
Me.Filter = "1 = 0"
Me.FilterOn = True
DoCmd.GoToRecord acDataForm, "frmLicense", acNewRec
Detail.BackColor = 12615808
Else
Dim cntrl As Control
Dim strFilter As String
For Each cntrl In Me.Controls
If TypeName(cntrl) = "Textbox" Or TypeName(cntrl) = "Combobox" Then
If Not Len(cntrl) = 0 Then
If Not Len(strFilter) = 0 Then strFilter = strFilter & "and "
strFilter = strFilter & cntrl.ControlSource & " like '*" & cntrl & "*' "
End If
End If
Next
If Not Len(strFilter) = 0 Then
DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
End If
Me.Filter = strFilter
Me.FilterOn = True
DoCmd.GoToRecord acDataForm, "frmLicense", acFirst
cmdDelete.Enabled = True
cmdGotoNew.Enabled = True
cmdMenu.Enabled = True
cmdLicHistory.Enabled = True
cmdComplaints.Enabled = True
cmdAddPrint.Enabled = True
cmdReceipts.Enabled = True
cmdLicensee.Enabled = True
cmdSearch.Caption = "&Search Mode"
' Detail.BackColor = 12632256
Detail.BackColor = -2147483633 ' Grey
End If
End Sub
However, depending on which fields are in focus, the shortcut keys will fire or not fire. Fields that nested in option groups will fire; fields nested in a tab control will not fire.
Is this behavior expected? This is a form level event, so I'm inclined to say that it's not. Any advice on debugging this would be appreciated.
Related
Sorry to bother you all again...
I am trying to create a login page where upon inputting the correct UserName AND password, it would filter a subform below so that they can see only their comments. I have it so that there are two buttons where one checks the Username and Password via VBA code and another button filters using a Macro... But I would like for one button to do everything so that if the password is incorrect, then they cannot see anything. The filter button currently works without a password and as long as there is a correct username it will filter that without looking at the password.
Option Compare Database
Option Explicit
Private Sub btnLogin_Click()
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("tbl1Employees", dbOpenSnapshot, dbReadOnly)
rs.FindFirst "UserName='" & Me.txtUserName & "'"
If rs.NoMatch Then
Me.lblWrongUser.Visible = True
Me.txtUserName.SetFocus
Exit Sub
End If
Me.lblWrongUser.Visible = False
If rs!Password <> Nz(Me.txtPassword, "") Then
Me.lblWrongPass.Visible = True
Me.txtPassword.SetFocus
Exit Sub
End If
Me.lblWrongPass.Visible = False
Dim search_text As String
search_text = Me.txtUserName
If Nz(Me.txtUserName.Value, "") = "" Then
Me.FilterOn = False
Me.txtUserName.SetFocus
Exit Sub
End If
Me.Filter = "UserName like '*" & Me.txtUserName.Value & "*' or userName like '*"
Me.FilterOn = True
Me.txtUserName.SetFocus
Me.txtUserName.Value = search_text
Me.txtUserName.SelStart = Len(Nz(Me.txtUserName. Value, "")) & 1
End Sub
I decided to just make a macro and do a docmd to run the macro at the end of the code :) thank you all
My intent is to deny users that do not meet a certain access level access to forms. I initially had issues with error code 3265 while writing the code for:
TempVars("EmployeeType").Value = rs!EmployeeType_ID.Value
This is no longer an issue; however, I cannot get access to the form even when the appropriate user is trying to enter. I've checked the spelling of table and column names multiple times as well.
Below is my code for the login (where I'm using the tempvars), followed by the code in form Load().
Option Compare Database
Option Explicit
Private Sub btnLogin_Click()
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("Employees", dbOpenSnapshot, dbReadOnly)
rs.FindFirst "UserName='" & Me.txtUserName & "'"
If rs.NoMatch = True Then
Me.lblWrongUser.Visible = True
Me.txtUserName.SetFocus
Exit Sub
End If
Me.lblWrongUser.Visible = False
If rs!Password <> Me.txtPassword Then
Me.lblWrongPass.Visible = True
Me.txtPassword.SetFocus
Exit Sub
End If
If IsNull(Me.txtUserName) Or IsNull(Me.txtPassword) Then
MsgBox "You must enter password or login ID.", vbOKOnly + vbInformation, "Required Data"
Me.txtUserName.SetFocus
Exit Sub
End If
Me.lblWrongPass.Visible = False
If rs!EmployeeType >= 4 Then
Dim prop As Property
On Error GoTo SetProperty
Set prop = CurrentDb.CreateProperty("AllowBypassKey", dbBoolean, False)
TempVars("UserName").Value = Me.txtUserName.Value
TempVars("EmployeeType").Value = rs!EmployeeType_ID.Value
CurrentDb.Properties.Append prop
SetProperty:
If MsgBox("Would you like to turn on the bypass key?", vbYesNo, "Allow Bypass") = vbYes Then
CurrentDb.Properties("AllowBypassKey") = True
Else
CurrentDb.Properties("AllowBypassKey") = False
End If
End If
Me.Visible = False
DoCmd.OpenForm "frmMain"
Globals.LoggingSignOn "Logon"
End Sub
Private Sub Form_Load()
Me.txtUserName = Null
Me.txtPassword = Null
Me.txtUserName.SetFocus
End Sub
Private Sub Form_Unload(Cancel As Integer)
Globals.LoggingSignOn "Logoff"
End Sub
Private Sub Form_Load()
If Nz(DLookup("HasAccess", "tbl9EmployeeAccess", "EmployeeType_ID=" & TempVars("EmployeeType") & " FormName='" & Me.Name & "'"), False) = False Then
MsgBox "You do not have access to access this location."
DoCmd.Close acForm, Me.Name
End If
End Sub
Thank you for your time, to anybody that looks into this.
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 am trying to fire an event if a specific combobox value appears more than 3 times ("md") in my control set. At the moment however, I keep getting high values like 32 or 40 despite there only being 8 comboboxes on my Access form. What am I doing wrong?
Dim mdCount As Integer
For Each ctl In Me.Controls
If ctl.ControlType = acComboBox Then
Set cmb = ctl
If (currentDropDown.Value = cmb.Value) And (Not currentDropDown Is cmb) And (Not currentDropDown.Value = "md") Then
MsgBox "You cannot select the same value twice."
End If
If (currentDropDown.Value = "md") Then
mdCount = mdCount + 1
End If
End If
Next ctl
Set ctl = Nothing
Private Sub Submit_Click()
'MsgBox mdCount
If (mdCount > 2) Then
MsgBox "Error!"
Exit Sub
End Sub
If i understand you correctly... try something like this (bit hard-coded, but very quick):
Function CheckMatches() As Integer
Dim sTmp As String
sTmp = IIf(Nz(Me.Combo1.Value, "") = "md", ";", "") & _
IIf(Nz(Me.Combo2.Value, "") = "md", ";", "") & _
IIf(Nz(Me.Combo3.Value, "") = "md", ";", "") 'and so on...
CheckMatches = UBound(Split(sTmp, ";")) + 1
'+1 is necessary in case of Option Base 0, _
'because LBound(array) starts from 0
End Function
Usage:
Private Sub Submit_Click()
Dim mdCount as Integer
mdCount = CheckMatches
If (mdCount > 2) Then
MsgBox "Error!"
Exit Sub
End Sub
Your requirements are not clear, so i can't help more ;(
When my database is opened, it shows a form with a "loading bar" that reports the progress of linking external tables and such, before showing a "Main Menu" form. The Main Menu has code that generates a form programmatically behind the scenes with buttons on it, and when that's done it saves and renames the form, and assigns it as the SourceObject to a subform.
This all works fine and dandy, that is, until I decide to make the buttons actually do something useful. In the loop that generates the buttons, it adds VBA code to the subform-to-be's module. For some reason, doing that makes VBA finish execution, then stop. This makes the (modal) loading form not disappear as there's an If statement that executes a DoCmd.Close to close the loading form when it's done loading. It also breaks functionality that depends on a global variable being set, since the global is cleared when execution halts.
Is there a better way to go about creating buttons that do stuff programmatically, short of ditching Access outright and writing real code? As much as I would love to, I'm forced to do it in Access in case I leave the company so the less tech-savvy employees can still work with it in my absence.
Below are bits and pieces of relevant code, if needed.
Form_USysSplash:
'Code that runs when the form is opened, before any processing.
Private Sub Form_Open(Cancel As Integer)
'Don't mess with things you shouldn't be.
If g_database_loaded Then
MsgBox "Please don't try to run the Splash form directly.", vbOKOnly, "No Touching"
Cancel = True
Exit Sub
End If
'Check if the user has the MySQL 5.1 ODBC driver installed.
Call CheckMysqlODBC 'Uses elfin majykks to find if Connector/ODBC is installed, puts the result into g_mysql_installed
If Not g_mysql_installed Then
Cancel = True
DoCmd.OpenForm "Main"
Exit Sub
End If
End Sub
'Code that runs when the form is ready to render.
Private Sub Form_Current()
'Prepare the form
boxProgressBar.width = 0
lblLoading.caption = ""
'Render the form
DoCmd.SelectObject acForm, Me.name
Me.Repaint
DoEvents
'Start the work
LinkOMTables
UpdateStatus "Done!"
DoCmd.OpenForm "Home"
f_done = True
End Sub
Private Sub Form_Timer() 'Timer property set to 100
If f_done Then DoCmd.Close acForm, Me.name
End Sub
Form_Home:
'Code run before the form is displayed.
Private Sub Form_Load()
'Check if the user has the MySQL 5.1 ODBC driver installed.
'Header contains an error message and a download link
If Not g_mysql_installed Then
FormHeader.Visible = True
Detail.Visible = False
Else
FormHeader.Visible = False
Detail.Visible = True
CreateButtonList Me, Me.subTasks
End If
End Sub
'Sub to create buttons on the form's Detail section, starting at a given height from the top.
Sub CreateButtonList(ByRef frm As Form, ByRef buttonPane As SubForm)
Dim rsButtons As Recordset
Dim newForm As Form
Dim newButton As CommandButton
Dim colCount As Integer, rowCount As Integer, curCol As Integer, curRow As Integer
Dim newFormWidth As Integer
Dim taskFormName As String, newFormName As String
Set rsButtons = CurrentDb.OpenRecordset("SELECT * FROM USysButtons WHERE form LIKE '" & frm.name & "'")
If Not rsButtons.EOF And Not rsButtons.BOF Then
taskFormName = "USys" & frm.name & "Tasks"
On Error Resume Next
If TypeOf CurrentProject.AllForms(taskFormName) Is AccessObject Then
buttonPane.SourceObject = ""
DoCmd.DeleteObject acForm, taskFormName
End If
Err.Clear
On Error GoTo 0
Set newForm = CreateForm
newFormName = newForm.name
With newForm
.Visible = False
.NavigationButtons = False
.RecordSelectors = False
.CloseButton = False
.ControlBox = False
.width = buttonPane.width
.HasModule = True
End With
rsButtons.MoveLast
rsButtons.MoveFirst
colCount = Int((buttonPane.width) / 1584) 'Twips: 1440 in an inch. 1584 twips = 1.1"
rowCount = Round(rsButtons.RecordCount / colCount, 0)
newForm.Detail.height = rowCount * 1584
curCol = 0
curRow = 0
Do While Not rsButtons.EOF
Set newButton = CreateControl(newForm.name, acCommandButton)
With newButton
.name = "gbtn_" & rsButtons!btn_name
.Visible = True
.Enabled = True
.caption = rsButtons!caption
.PictureType = 2
.Picture = rsButtons!img_name
.PictureCaptionArrangement = acBottom
.ControlTipText = rsButtons!tooltip
.OnClick = "[Event Procedure]"
'This If block is the source of my headache.
If Not IsNull(rsButtons!open_query) And rsButtons!open_query <> "" Then
newForm.Module.InsertLines newForm.Module.CountOfLines, _
"Private Sub gbtn_" & rsButtons!btn_name & "_Click()"
newForm.Module.InsertLines newForm.Module.CountOfLines, _
"DoCmd.OpenQuery """ & rsButtons!open_query & """"
newForm.Module.InsertLines newForm.Module.CountOfLines, _
"End Sub" & vbCrLf & vbCrLf
ElseIf Not IsNull(rsButtons!open_form) And rsButtons!open_form <> "" Then
newForm.Module.InsertLines newForm.Module.CountOfLines, _
"Private Sub gbtn_" & rsButtons!btn_name & "_Click()"
newForm.Module.InsertLines newForm.Module.CountOfLines, _
"DoCmd.OpenForm """ & rsButtons!open_form & """"
newForm.Module.InsertLines newForm.Module.CountOfLines, _
"End Sub" & vbCrLf & vbCrLf
End If
.height = 1584
.width = 1584
.Top = 12 + (curRow * 1584)
.Left = 12 + (curCol * 1584)
.BackThemeColorIndex = 1
.HoverThemeColorIndex = 4 'Accent 1
.HoverShade = 0
.HoverTint = 40 '60% Lighter
.PressedThemeColorIndex = 4 'Accent 1
.PressedShade = 0
.PressedTint = 20 '80% Lighter
End With
curCol = curCol + 1
If curCol = colCount Then
curCol = 0
curRow = curRow + 1
End If
rsButtons.MoveNext
Loop
DoCmd.Close acForm, newForm.name, acSaveYes
DoCmd.Rename taskFormName, acForm, newFormName
buttonPane.SourceObject = taskFormName
End If
End Sub
There is no need to write code while code is running, especially as you are writing essentially the same code over and over again. All you need do is call a function instead of an event procedure.
In your code above write the OnClick event like this:
If Not IsNull(rsButtons!open_query) And rsButtons!open_query <> "" Then
.OnClick = "=MyOpenForm(""" & rsButtons!open_form & """)"
ElseIf Not IsNull(rsButtons!open_form) And rsButtons!open_form <> "" Then
.OnClick = "=MyOpenQuery(""" & rsButtons!open_form & """)"
End If
Then create these two permanent (non-generated) functions somewhere the form can see them:
Public Function MyOpenForm(FormName as String)
DoCmd.OpenForm FormName
End Function
Public Function MyOpenQuery(QueryName as String)
DoCmd.OpenQuery QueryName
End Function
And ditch the code writing to the module.