How to create controls at run time Access VB? - ms-access

How can you create controls at run time with VB code in Microsoft Access? after some digging I found that this is possible with the CreateControl function. The problem is every random forum I find online has some code similar to this:
Private Sub Button_Click()
Call AddLabel
End Sub
Function AddLabel()
Set ctl = CreateControl("MyForm", acLabel, acDetail, "", "", 0, 0, 100, 100)
With ctl
.name = "myTextBox"
.Caption = "Hello World!"
.Height = 50
.Width = 100
.FontSize = 11
.Visible = True
End With
End Function
but this code appears to not create a visible label.
In my case I'm just trying to learn how to get this to work. So I created a blank form with a button that when clicked will create a label that says "Hello world!". What I'm expecting to happen is a textbox will display in the top left of the form when the button is clicked. I'm curious if anyone could help show me a simple example of some code that actually works.
Before anyone says I can create a label and hide it then change its visibilty property, I know. But I'd like to know how to create controls dynamically and getting this simple example to actually work will greatly help my understanding.

The documentation you need is here (these are specifically for Access VBA):
Application.CreateControl Method (Office 2007)
Application.CreateControl Method (Office 2003)
According to the documentatin, there are some big limitations to this feature:
Limited to 754 controls over the lifetime of the form (this is not reset by deleting them, so you are likely to run into this limit quickly)
Must be done in Design view (so it can't be done in mde/accde)
It is questionable how it will perform in a multi-user environment.
Because of these limitations, it is inadvisable, unless you are using to design forms initially.
Duplicate Question: How do you dynamically create controls on a MS Access form?
In response to the OP's suggestion, here is my test code which was able to add 40 controls and repeat the process 50 times without exceeding the 754 limit (I reused 40 names in my test).
Caveat 1 This is inadvisable because it can only be done in design view which will not work in an mde/accde.
Caveat 2: It is questionable how it will perform in a multi-user environment.
This code is from a form with two buttons. It opens a second form named "Form2"
Option Compare Database
Option Explicit
Private Const FORM_NAME As String = "Form2"
Private m_nCounter As Long
Private Sub cmdCreate_Click()
runDynamicForm
End Sub
Private Sub cmdRepeat_Click()
Dim n As Long
m_nCounter = 0
For n = 0 To 50
runDynamicForm
DoEvents
DoCmd.Close acForm, FORM_NAME, acSaveNo
DoEvents
Next 'n
MsgBox m_nCounter
End Sub
Private Sub runDynamicForm()
Const DYNAMIC_TAG As String = "dynamic"
Dim n As Long
Dim frm As Form
Dim ctl As Access.Control
On Error GoTo EH
Application.Echo False
DoCmd.OpenForm FORM_NAME, acDesign
Set frm = Application.Forms(FORM_NAME)
For n = frm.Controls.Count - 1 To 0 Step -1
Set ctl = frm.Controls(n)
If ctl.Tag = DYNAMIC_TAG Then
Application.DeleteControl FORM_NAME, ctl.Name
End If
Next 'n
For n = 1 To 20
With Application.CreateControl(FORM_NAME, acLabel, acDetail, , , 400, n * 300, 1500, 300)
.Name = "lbl" & n
.Caption = "Question " & n
.Visible = True
.Tag = DYNAMIC_TAG
End With
With Application.CreateControl(FORM_NAME, acTextBox, acDetail, , , 2000, n * 300, 3000, 300)
.Name = "txt" & n
.Visible = True
.TabIndex = n - 1
.Tag = DYNAMIC_TAG
End With
m_nCounter = m_nCounter + 2
Next 'n
DoCmd.Close acForm, FORM_NAME, acSaveYes
DoCmd.OpenForm FORM_NAME, acNormal
GoTo FINISH
EH:
With Err
MsgBox "Error:" & vbTab & .Number & vbCrLf _
& "Source" & vbTab & .Source & vbCrLf _
& .Description
End With
FINISH:
Application.Echo True
End Sub

I took that upove code and simplified it as it was long winded, and turned it into a a sample code for my own future use. Hope it helps someone in the future.
Public Sub runDynamicCreateControls()
Dim FormName As String
Dim NumControls As Integer
Dim n As Long
Dim ctl As Access.Control
Dim ctlname As String
On Error GoTo EH
Application.Echo False
FormName = "createcontrolF" 'Input Name of Form
NumControls = 20 'input number of controls
ctlname = "txt" 'input control name
DoCmd.OpenForm FormName, acDesign
For n = 1 To NumControls
With Application.CreateControl(FormName, acTextBox, acDetail, , , 1000,1000, 1100, 600)
.Name = ctlname & "_" & n
.Visible = True
.Tag = n
End With
Next 'n
DoCmd.Close acForm, FormName, acSaveYes
DoCmd.OpenForm FormName, acNormal
GoTo FINISH
EH:
With Err
MsgBox "Error:" & vbTab & .Number & vbCrLf _
& "Source" & vbTab & .Source & vbCrLf _
& .Description
End With
FINISH:
Application.Echo True
End Sub

Whenever I attempt to run your code I get the runtime error of:
Run-time error '6062':
You must be in Design or Layout View to create or delete controls.
Based off of that information it seems like dynamically creating controls in runtime isn't going to be possible.

You might be only missing DoCmd.Restore, here is an example on how to dynamically create form, data bind it, and create controls, all in runtime.
Sub NewControls()
Dim frm As Form
Dim ctlLabel As Control, ctlText As Control
Dim intDataX As Integer, intDataY As Integer
Dim intLabelX As Integer, intLabelY As Integer
' Create new form with Orders table as its record source.
Set frm = CreateForm
frm.RecordSource = "Orders"
' Set positioning values for new controls.
intLabelX = 100
intLabelY = 100
intDataX = 1000
intDataY = 100
' Create unbound default-size text box in detail section.
Set ctlText = CreateControl(frm.Name, acTextBox, , "", "", _
intDataX, intDataY)
' Create child label control for text box.
Set ctlLabel = CreateControl(frm.Name, acLabel, , _
ctlText.Name, "NewLabel", intLabelX, intLabelY)
' Restore form.
DoCmd.Restore
End Sub

Related

DoEvent() Returns 0 BUT Run-time Error 2585 This action can't be carried out while processing a form or report event

This code was running without a hitch, but now getting Error 2585.
I have looked at Gustav's answer and Gord Thompson's answer but unless I am missing something (quite possible!) the first does not work and the second seems inapplicable. I saw on another site a suggestion that there might be a duplicate record ID, but I check for that possibility.
I put a call to DoEvent() in response to this error but it returns zero. I also wait for 10 seconds to let other processes run. Still receive the error.
Private Sub SaveData_Click()
Dim myForm As Form
Dim myTextBox As TextBox
Dim myDate As Date
Dim myResponse As Integer
If IsNull(Forms!Ecoli_Data!DateCollected.Value) Then
myReponse = myResponse = MsgBox("You have not entered all the required data. You may quit data entry by hitting 'Cancel'", vbOKOnly, "No Sample Date")
Forms!Ecoli_Data.SetFocus
Forms!Ecoli_Data!Collected_By.SetFocus
GoTo endOfSub
End If
If Me.Dirty Then Me.Dirty = False
myDate = Me.DateCollected.Value
Dim yearAsString As String, monthAsString As String, dayAsString As String, clientInitial As String
Dim reportNumberText As String
reportNumberText = Me!SampleNumber.Value
Debug.Print "reportNumberText = " & reportNumberText
Debug.Print "CollectedBy Index: " & Me!Collected_By & " Employee Name: " & DLookup("CollectedBy", "Data_Lookup", Me.Collected_By)
Dim whereString As String
whereString = "SampleNumber=" & "'" & reportNumberText & "'"
Debug.Print whereString
On Error GoTo errorHandling
DoCmd.OpenReport "ECOLI_Laboratory_Report", acViewPreview, , whereString
DoCmd.PrintOut
DoCmd.Close acReport, "ECOLI_Laboratory_Report", acSaveNo
Dim eventsOpen As Integer
eventsOpen = DoEvents()
Debug.Print "Number of Open Events = " & DoEvents()
Dim PauseTime, Start, Finish, TotalTime
PauseTime = 10 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
myResponse = MsgBox("Processing Report Took " & TotalTime & " seconds.", vbOKOnly)
myResponse = MsgBox("Do you want to add more data?", vbYesNo, "What Next?")
If myResponse = vbYes Then
DoCmd.Close acForm, "ECOLI_Data", acSaveYes
Error Generated By Line Above and occurs whether response Y or N to MsgBox.
DoCmd.OpenForm "ECOLI_Data", acNormal, , , acFormAdd
DoCmd.GoToRecord , , acNewRec
Else
DoCmd.Close acForm, "ECOLI_Data", acSaveYes
End If
Exit Sub
errorHandling:
If Err.Number = 2501 Then
myResponse = MsgBox("Printing Job Cancelled", vbOkayOnly, "Report Not Printed")
ElseIf Err.Number = 0 Then
'Do nothing
Else
Debug.Print "Error Number: " & Err.Number & ": " & Err.Description
myResponse = MsgBox("An Error occurred: " & Err.Description, vbOKOnly, "Error #" & Err.Number)
End If
If Application.CurrentProject.AllForms("ECOLI_Data").IsLoaded Then DoCmd.Close acForm, "ECOLI_Data", acSaveNo
If Application.CurrentProject.AllReports("ECOLI_Laboratory_Report").IsLoaded Then DoCmd.Close acReport, "ECOLI_Laboratory_Report", acSaveNo
endOfSub:
End Sub
Any idea on what am I missing here? Thanks.
I can't replicate the problem, but the following might help:
I assume you run into troubles because you're closing and opening the form in the same operation. To avoid doing this, you can open up a second copy of the form, and close the form once the second copy is open. This avoids that issue.
To open a second copy of the form:
Public Myself As Form
Public Sub CopyMe()
Dim myCopy As New Form_CopyForm
myCopy.Visible = True
Set myCopy.Myself = myCopy
End Sub
(CopyForm is the form name)
To close a form that may or may not be a form created by this function
Public Sub CloseMe()
If Myself Is Nothing Then
DoCmd.Close acForm, Me.Name
Else
Set Myself = Nothing
End If
End Sub
More information on having multiple variants of the same form open can be found here, but my approach differs from the approach suggested here, and doesn't require a second object to hold references and manage copies.
This line of code
`DoCmd.Close acForm, "ECOLI_Data", acSaveYes`
doesn't save the record you are on, it just saves any changes to the form design.
You should probably use
If Me.Dirty Then Me.dirty = False
to force a save of the current record if any data has changed.

Should I re-purpose subform controls on one form or just create multiple forms?

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)

Compare two recordset variables gives type mismatch

I have a bound form with several subforms. some of these subforms can 0 or more records, others have 1 or more.
The form is always open in read-only and on it there are an "edit" and a "close" button.
When the user clicks on the edit button I save the content of the current record togehter with all records of the subforms so that when he/she clicks on the close button I can ask wether to save or not and, if not, discard the changes restoring from saved records.
So far this is the code of the edit button (where GclnAllCnts is a global variable of type Dictionary):
Private Sub EditLibroBtn_Click()
On Error GoTo Err_EditLibroBtn_Click
Dim lngID As Long
Dim ctlCnt As Control
Dim rs As Recordset
lngID = Me.ID
Set GclnAllCnts = New Dictionary
GclnAllCnts.Add Me.Name, Me.RecordsetClone
For Each ctlCnt In Me.Controls
If (ctlCnt.ControlType = acSubform) Then
Set rs = ctlCnt.Form.RecordsetClone
If rs.RecordCount > 0 Then
GclnAllCnts.Add ctlCnt.Name, ctlCnt.Form.RecordsetClone
Else
GclnAllCnts.Add ctlCnt.Name, Null
End If
End If
Next
DoCmd.Close acForm, Me.Name
DoCmd.OpenForm GCstMainFrmName, , , "ID = " & lngID, acFormEdit, acDialog
Exit_EditLibroBtn_Click:
Set ctlCnt = Nothing
Set rs = Nothing
Exit Sub
Err_EditLibroBtn_Click:
MsgBox err.Description & vbNewLine & "Error number: " & err.Number, vbCritical, "Errore"
Resume Exit_EditLibroBtn_Click
End Sub
And this is the code of the close button:
Private Sub ChiudiBtn_Click()
On Error GoTo Err_ChiudiBtn_Click
Dim intBoxAwr As Integer
Dim stSQL As String
Dim vKey As Variant
Dim ctlCnt As Control
Dim clnAllCnts As Dictionary
Dim bSaveNeeded As Boolean
bSaveNeeded = False
If (Me.AllowEdits And Me.ID <> "" And Not IsNull(Me.ID)) Then
Set clnAllCnts = New Dictionary
clnAllCnts.Add Me.Name, Me.RecordsetClone
For Each ctlCnt In Me.Controls
If (ctlCnt.ControlType = acSubform) Then
Set rs = ctlCnt.Form.RecordsetClone
If rs.RecordCount > 0 Then
clnAllCnts.Add ctlCnt.Name, ctlCnt.Form.RecordsetClone
Else
clnAllCnts.Add ctlCnt.Name, Null
End If
End If
Next
If clnAllCnts.Count <> GclnAllCnts.Count Then
bSaveNeeded = True
Else
For Each vKey In clnAllCnts.keys()
If Not GclnAllCnts.Exists(vKey) Then
bSaveNeeded = True
Exit For
Else
'*********** Next Gives error **********
If clnAllCnts.Item(vKey) <> GclnAllCnts.Item(vKey) Then
bSaveNeeded = True
Exit For
End If
End If
Next
End If
If bSaveNeeded Then
intBoxAwr = MsgBox("Salvare le modifiche al libro?", vbYesNo + vbQuestion, "Salvare")
If intBoxAwr = vbYes Then
'etc., omitting code
End Sub
The error I get is Type mismatch (nr. 13) and it is given by the <> comparison (I can Debug.print IsNull(clnAllCnts.Item(vKey)) and IsNull(GclnAllCnts.Item(vKey)).
How can I compare the two recordset variables?
Comparing two Recordset objects by simply saying If rst1 <> rst2 could be dicey anyway, because what does that really mean? Such an expression could very well return True every time, if rst1 and rst2 really are different objects (even if they are of the same object Type).
It appears that you are interested in whether the contents of the two Recordsets is the same. In that case, I would be inclined to serialize the recordset data and store the resulting String instead of storing the Recordset object itself.
The following VBA Function may prove helpful in that case. It loops through a recordset object and produces a JSON-like string containing the current recordset data.
(Note that the function may NOT necessarily produce valid JSON. It doesn't escape non-printing characters like vbCr and vbLf. It doesn't escape backslashes (\). It stores all values as either "string" or null. In other words, in its current form it is not designed to produce a string that could later be deserialized.)
Private Function rstSerialize(ByVal rst As DAO.Recordset)
' loop through the recordset and generate a JSON-like string
' NB: This code will NOT necessarily produce valid JSON!
'
Dim s As String, fld As DAO.Field, rowCount As Long, fldCount As Long
s = "{"
If Not (rst.BOF And rst.EOF) Then
rst.MoveFirst
rowCount = 0
Do Until rst.EOF
If rowCount > 0 Then
s = s & ", "
End If
s = s & """row"": {"
fldCount = 0
For Each fld In rst.Fields
If fldCount > 0 Then
s = s & ", "
End If
s = s & """" & fld.Name & """: " & IIf(IsNull(fld.Value), "null", """" & fld.Value & """")
fldCount = fldCount + 1
Next
s = s & "}"
rowCount = rowCount + 1
rst.MoveNext
Loop
End If
s = s & "}"
rstSerialize = s
End Function
Data Example: If the Recordset contained
DonorID Amount
------- ------
1 10
2 20
the function would return the string
{"row": {"DonorID": "1", "Amount": "10"}, "row": {"DonorID": "2", "Amount": "20"}}
Usage Example: On a form that contains a subform, a button on the main form could do the following
Private Sub Command3_Click()
Dim rst As DAO.Recordset, originalState As String
Set rst = Me.MemberDonationsSubform.Form.RecordsetClone
originalState = rstSerialize(rst)
rst.MoveFirst
rst.Edit
rst!Amount = rst!Amount + 1
rst.Update
Debug.Print "(Recordset updated.)"
If rstSerialize(rst) = originalState Then
Debug.Print "Recordset does not appear to have changed."
Else
Debug.Print "Recordset appears to have changed."
End If
End Sub
which would print the following in the VBA Immediate Window
(Recordset updated.)
Recordset appears to have changed.

DAO access recordset not updating

I have an access report that updates 4 image controls based on a table that is sourcing images from a directory. The report generates a page per record, however the image controls are not changing after page 1 (just showing same images for all the other pages). Appartently, the code worked fine on Windows XP and now does not work on Windows 7 OS (both used Office 07). Here is the code:
Private Sub Report_Current()
UpdateImages
End Sub
Private Sub Report_Load()
UpdateImages
End Sub
Private Sub Report_Page()
UpdateImages
End Sub
Private Sub UpdateImages()
On Error GoTo errHandler
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("SELECT Image_Loc, Image_Name FROM HH_Media WHERE InspectionID = " & CInt(Me.InspectionID.Value) & " ORDER BY MediaID ASC")
If Not RS.BOF And Not RS.EOF Then
Dim i As Integer
For i = 1 To 4
If Not RS.EOF Then
Dim pictureCtrl As Image
Set pictureCtrl = GetControl("Image" & i)
Dim strImage As String
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
If Not pictureCtrl Is Nothing Then
If FileExists(strImage) Then
pictureCtrl.Picture = strImage
SetLabel "lblImage" & i, RS.Fields("Image_Name").Value
Else
pictureCtrl.Picture = ""
SetLabel "lblImage" & i, "Does not exist"
End If
End If
RS.MoveNext
Else
Exit For
End If
Next
End If
RS.Close
Set RS = Nothing
Exit Sub
errHandler:
MsgBox "An error occurred while updating the form display." & vbNewLine & Err.Description, vbApplicationModal + vbCritical + vbDefaultButton1 + vbOKOnly, Me.Name
Resume Next
End Sub
The images do exist in the directory that are referenced in the table. Any ideas of what is missing?
Thank You
Whenever I need to do some dynamic content I always use the [section]_Format event - so if your controls are on the Detail section then:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
If FormatCount = 1 then 'only need to do this once per record
UpdateImages
Endif
End Sub
I've never seen the GetControl method, and I don't have a lot of experience using the Image control, but it seems like that the Dim statement should read more like:
Dim pictureCtrl as Control
Set pictureCtrl = Me.Controls("Image" & i)
I would insert a break and verify that
strImage = RS.Fields("Image_Loc").Value & "\" & RS.Fields("Image_Name").Value
is returning values you expect. You can also shorten these to:
strImage = rs!Image_Loc & "\" & rs!Image_Name
sometimes Access doesn't like the added ".value" as this is already the default return.

Programmatically Create a Button That Opens a Form In Access

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.