reference subform of subform from 4th form - forms

Question

I have tried every suggestion from many different sites, but none of them work, not even Microsoft's KB articles or references suggested in Stack Overflow.
I have a main form [frmMain], with a sub form called [frmTaskTracking] and a sub form within that sub form called [sfmActivites subform]. I need to obtain the filter for [sfmActivites subform] from a popup form [frmExportTasks] which is opened from [frmTaskTracking] as such:
[frmMain]
[frmTaskTracking]
[sfmActivites subform]
Filter
[frmExportTasks]
What is the correct way to reference the filter for the form [sfmActivites subform] in VBA??
Thanks so much!

Answer 1

Your question is very conceptual, so this answer may or may not apply to your specific issue.
I once had to create a CRUD app involving master-detail data, and I had to do it in Excel VBA, and didn't have access to the database... so I wrote the code against abstractions and implemented Model-View-Presenter, Command and Repository+UnitOfWork patterns... which might be slightly overkill for your needs.
However overkill this solution might be, it's as SOLID as VBA gets, and has allowed me to reuse the same form/view for every single one of the "master" and "details" tables I wanted to work with - again, your post isn't exactly crystal-clear on what it is exactly that you're doing, so I'm just going to expose the solution that worked for me. Is it the right way? Depends what you're doing. It was the right way for me, as I could test the entire functionality with mock data, and everything just worked when I got to the office and swapped the unit of work for one that actually connected to the database.
The key point is that the Presenter knows its MasterId, and its DetailsPresenter if it has one:
IPresenter
Option Explicit
Public Property Get UnitOfWork() As IUnitOfWork
End Property
Public Property Set UnitOfWork(ByVal value As IUnitOfWork)
End Property
Public Property Get View() As IView
End Property
Public Property Set View(ByVal value As IView)
End Property
Public Sub Show()
End Sub
Public Function ExecuteCommand(ByVal commandId As CommandType) As Variant
End Function
Public Function CanExecuteCommand(ByVal commandId As CommandType) As Boolean
End Function
Public Property Get DetailsPresenter() As IPresenter
End Property
Public Property Set DetailsPresenter(ByVal value As IPresenter)
End Property
Public Property Get MasterId() As Long
End Property
Public Property Let MasterId(ByVal value As Long)
End Property
Say I have a CategoriesPresenter and a SubCategoriesPresenter, I could have the CategoriesPresenter implemented like this:
Option Explicit
Private Type tPresenter
UnitOfWork As IUnitOfWork
DetailsPresenter As IPresenter
View As IView
End Type
Private this As tPresenter
Implements IPresenter
Implements IDisposable
Public Property Get UnitOfWork() As IUnitOfWork
Set UnitOfWork = this.UnitOfWork
End Property
Public Property Set UnitOfWork(ByVal value As IUnitOfWork)
Set this.UnitOfWork = value
End Property
Public Property Get View() As IView
Set View = this.View
End Property
Public Property Set View(ByVal value As IView)
Set this.View = value
End Property
Public Property Get DetailsPresenter() As IPresenter
Set DetailsPresenter = this.DetailsPresenter
End Property
Public Property Set DetailsPresenter(ByVal value As IPresenter)
Set this.DetailsPresenter = value
End Property
Public Sub Show()
IPresenter_ExecuteCommand RefreshCommand
View.Show
End Sub
Private Function NewCategory(Optional ByVal id As Long = 0, Optional ByVal description As String = vbNullString) As SqlResultRow
Dim result As SqlResultRow
Dim values As New Dictionary
values.Add "id", id
values.Add "description", description
Set result = UnitOfWork.Repository("Categories").NewItem(View.Model, values)
Set NewCategory = result
End Function
Private Sub Class_Terminate()
Dispose
End Sub
Private Sub Dispose()
If Not View Is Nothing Then Unload View
Disposable.Dispose this.UnitOfWork
Disposable.Dispose this.DetailsPresenter
Set this.UnitOfWork = Nothing
Set this.View = Nothing
Set this.DetailsPresenter = Nothing
End Sub
Private Sub IDisposable_Dispose()
Dispose
End Sub
Private Function IPresenter_CanExecuteCommand(ByVal commandId As CommandType) As Boolean
Dim result As Boolean
Select Case commandId
Case CommandType.CloseCommand, CommandType.RefreshCommand, CommandType.AddCommand
result = True
Case CommandType.DeleteCommand, _
CommandType.EditCommand
result = (Not View.SelectedItem Is Nothing)
Case CommandType.ShowDetailsCommand
If View.SelectedItem Is Nothing Then Exit Function
result = GetDetailsModel.Count > 0
End Select
IPresenter_CanExecuteCommand = result
End Function
Private Property Set IPresenter_DetailsPresenter(ByVal value As IPresenter)
Set DetailsPresenter = value
End Property
Private Property Get IPresenter_DetailsPresenter() As IPresenter
Set IPresenter_DetailsPresenter = DetailsPresenter
End Property
Private Function GetDetailsModel() As SqlResult
Set GetDetailsModel = DetailsPresenter.UnitOfWork.Repository("SubCategories") _
.GetAll _
.WhereFieldEquals("CategoryId", View.SelectedItem("Id"))
End Function
Private Function IPresenter_ExecuteCommand(ByVal commandId As CommandType) As Variant
Select Case commandId
Case CommandType.CloseCommand
View.Hide
Case CommandType.RefreshCommand
Set View.Model = UnitOfWork.Repository("Categories").GetAll
Case CommandType.ShowDetailsCommand
Set DetailsPresenter.View.Model = GetDetailsModel
DetailsPresenter.MasterId = View.SelectedItem("id")
DetailsPresenter.Show
Case CommandType.AddCommand
ExecuteAddCommand
Case CommandType.DeleteCommand
ExecuteDeleteCommand
Case CommandType.EditCommand
ExecuteEditCommand
End Select
End Function
Private Sub ExecuteAddCommand()
Dim description As String
If Not RequestUserInput(prompt:=GetResourceString("AddCategoryMessageText"), _
title:=GetResourceString("AddPromptTitle"), _
outResult:=description, _
default:=GetResourceString("DefaultCategoryDescription")) _
Then
Exit Sub
End If
UnitOfWork.Repository("Categories").Add NewCategory(description:=description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Sub ExecuteDeleteCommand()
Dim id As Long
id = View.SelectedItem("id")
Dim childRecords As Long
childRecords = GetDetailsModel.Count
If childRecords > 0 Then
MsgBox StringFormat(GetResourceString("CannotDeleteItemWithChildItemsMessageText"), childRecords), _
vbExclamation, _
GetResourceString("CannotDeleteItemWithChildItemsMessageTitle")
Exit Sub
End If
If RequestUserConfirmation(StringFormat(GetResourceString("ConfirmDeleteItemMessageText"), id)) Then
UnitOfWork.Repository("Categories").Remove id
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End If
End Sub
Private Sub ExecuteEditCommand()
Dim id As Long
id = View.SelectedItem("id")
Dim description As String
If Not RequestUserInput(prompt:=StringFormat(GetResourceString("EditCategoryDescriptionText"), id), _
title:=GetResourceString("EditPromptTitle"), _
outResult:=description, _
default:=View.SelectedItem("description")) _
Then
Exit Sub
End If
UnitOfWork.Repository("Categories").Update id, NewCategory(id, description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Property Let IPresenter_MasterId(ByVal value As Long)
'not implemented
End Property
Private Property Get IPresenter_MasterId() As Long
'not implemented
End Property
Private Property Set IPresenter_UnitOfWork(ByVal value As IUnitOfWork)
Set UnitOfWork = value
End Property
Private Property Get IPresenter_UnitOfWork() As IUnitOfWork
Set IPresenter_UnitOfWork = UnitOfWork
End Property
Private Sub IPresenter_Show()
Show
End Sub
Private Property Set IPresenter_View(ByVal value As IView)
Set View = value
End Property
Private Property Get IPresenter_View() As IView
Set IPresenter_View = View
End Property
The SubCategoriesPresenter looks like this:
Option Explicit
Private Type tPresenter
MasterId As Long
UnitOfWork As IUnitOfWork
DetailsPresenter As IPresenter
View As IView
End Type
Private this As tPresenter
Implements IPresenter
Implements IDisposable
Private Function NewSubCategory(Optional ByVal id As Long = 0, Optional ByVal categoryId As Long = 0, Optional ByVal description As String = vbNullString) As SqlResultRow
Dim result As SqlResultRow
Dim values As New Dictionary
values.Add "id", id
values.Add "categoryid", categoryId
values.Add "description", description
Set result = UnitOfWork.Repository("SubCategories").NewItem(View.Model, values)
Set NewSubCategory = result
End Function
Public Property Get UnitOfWork() As IUnitOfWork
Set UnitOfWork = this.UnitOfWork
End Property
Public Property Set UnitOfWork(ByVal value As IUnitOfWork)
Set this.UnitOfWork = value
End Property
Public Property Get View() As IView
Set View = this.View
End Property
Public Property Set View(ByVal value As IView)
Set this.View = value
View.Resize width:=400
End Property
Public Sub Show()
View.Show
End Sub
Private Sub Class_Terminate()
Dispose
End Sub
Private Sub Dispose()
If Not View Is Nothing Then Unload View
Disposable.Dispose this.UnitOfWork
Disposable.Dispose this.DetailsPresenter
Set this.UnitOfWork = Nothing
Set this.View = Nothing
Set this.DetailsPresenter = Nothing
End Sub
Private Sub IDisposable_Dispose()
Dispose
End Sub
Private Function IPresenter_CanExecuteCommand(ByVal commandId As CommandType) As Boolean
Dim result As Boolean
Select Case commandId
Case CommandType.CloseCommand, _
CommandType.RefreshCommand, _
CommandType.AddCommand
result = True
Case CommandType.DeleteCommand, _
CommandType.EditCommand
result = (Not View.SelectedItem Is Nothing)
End Select
IPresenter_CanExecuteCommand = result
End Function
Private Property Set IPresenter_DetailsPresenter(ByVal value As IPresenter)
'not implemented
End Property
Private Property Get IPresenter_DetailsPresenter() As IPresenter
'not implemented
End Property
Private Sub ExecuteAddCommand()
Dim description As String
If Not RequestUserInput(prompt:=GetResourceString("AddSubCategoryMessageText"), _
title:=GetResourceString("AddPromptTitle"), _
outResult:=description, _
default:=GetResourceString("DefaultSubCategoryDescription")) _
Then
Exit Sub
End If
UnitOfWork.Repository("SubCategories").Add NewSubCategory(categoryId:=this.MasterId, description:=description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Sub ExecuteDeleteCommand()
Dim id As Long
id = View.SelectedItem("id")
If RequestUserConfirmation(StringFormat(GetResourceString("ConfirmDeleteItemMessageText"), id)) Then
UnitOfWork.Repository("SubCategories").Remove id
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End If
End Sub
Private Sub ExecuteEditCommand()
Dim id As Long
id = View.SelectedItem("id")
Dim description As String
If Not RequestUserInput(prompt:=StringFormat(GetResourceString("EditSubCategoryDescriptionText"), id), _
title:=GetResourceString("EditPromptTitle"), _
outResult:=description, _
default:=View.SelectedItem("description")) _
Then
Exit Sub
End If
UnitOfWork.Repository("SubCategories").Update id, NewSubCategory(id, this.MasterId, description)
UnitOfWork.Commit
IPresenter_ExecuteCommand RefreshCommand
End Sub
Private Function IPresenter_ExecuteCommand(ByVal commandId As CommandType) As Variant
Select Case commandId
Case CommandType.CloseCommand
View.Hide
Case CommandType.RefreshCommand
Set View.Model = UnitOfWork.Repository("SubCategories") _
.GetAll _
.WhereFieldEquals("CategoryId", this.MasterId)
Case CommandType.EditCommand
ExecuteEditCommand
Case CommandType.DeleteCommand
ExecuteDeleteCommand
Case CommandType.AddCommand
ExecuteAddCommand
End Select
End Function
Private Property Let IPresenter_MasterId(ByVal value As Long)
this.MasterId = value
End Property
Private Property Get IPresenter_MasterId() As Long
IPresenter_MasterId = this.MasterId
End Property
Private Property Set IPresenter_UnitOfWork(ByVal value As IUnitOfWork)
Set UnitOfWork = value
End Property
Private Property Get IPresenter_UnitOfWork() As IUnitOfWork
Set IPresenter_UnitOfWork = UnitOfWork
End Property
Private Sub IPresenter_Show()
Show
End Sub
Private Property Set IPresenter_View(ByVal value As IView)
Set View = value
End Property
Private Property Get IPresenter_View() As IView
Set IPresenter_View = View
End Property
In your case you would have a DetailsPresenter isntance right here, and that child would also have its own DetailsPresenter instance.
The hardest thing for me, was to implement the commands. Here's something that might help:
CommandCallback
Option Explicit
Private owner As IPresenter
Implements ICommandCallback
Public Property Get CallbackOwner() As IPresenter
Set CallbackOwner = owner
End Property
Public Property Set CallbackOwner(ByVal value As IPresenter)
Set owner = value
End Property
Private Property Set ICommandCallback_CallbackOwner(ByVal value As IPresenter)
Set owner = value
End Property
Private Property Get ICommandCallback_CallbackOwner() As IPresenter
Set ICommandCallback_CallbackOwner = owner
End Property
Private Function ICommandCallback_CanExecute(ByVal cmd As CommandType) As Boolean
If owner Is Nothing Then Exit Function
ICommandCallback_CanExecute = CallByName(owner, "CanExecuteCommand", VbMethod, cmd)
End Function
Private Sub ICommandCallback_Execute(ByVal cmd As CommandType)
If owner Is Nothing Then Exit Sub
If Not ICommandCallback_CanExecute(cmd) Then Exit Sub
CallByName owner, "ExecuteCommand", VbMethod, cmd
End Sub
This allowed me to get the logic completely outside of the view, and into the presenters.
Here's the code-behind for my form:
Option Explicit
Private Type tView
Model As SqlResult
Selection As SqlResultRow
Callback As ICommandCallback
End Type
Private this As tView
'MinSize is determined by design-time size.
Private minHeight As Integer
Private minWidth As Integer
Private layoutBindings As New List
Implements IView
Private Sub IView_Resize(Optional ByVal width As Integer, Optional ByVal height As Integer)
If width <> 0 Then Me.width = width
If height <> 0 Then Me.height = height
End Sub
Private Sub UserForm_Initialize()
BindControlLayouts
minHeight = Me.height
minWidth = Me.width
End Sub
Private Sub BindControlLayouts()
'todo: refactor this
Dim buttonLeftAnchor As Integer
buttonLeftAnchor = EditButton.Left
Dim buttonMargin As Integer
buttonMargin = 2
EditKeyButton.Top = AddButton.Top
EditDateButton.Top = EditKeyButton.Top + EditKeyButton.height + buttonMargin
EditDescriptionButton.Top = EditDateButton.Top + EditDateButton.height + buttonMargin
EditKeyButton.Left = buttonLeftAnchor
EditDateButton.Left = buttonLeftAnchor
EditDescriptionButton.Left = buttonLeftAnchor
Dim instructionsLabelLayout As New ControlLayout
instructionsLabelLayout.Bind Me, InstructionsLabel, AnchorAll
Dim backgroundImageLayout As New ControlLayout
backgroundImageLayout.Bind Me, BackgroundImage, AnchorAll
Dim itemsListLayout As New ControlLayout
itemsListLayout.Bind Me, ItemsList, AnchorAll
Dim closeButtonLayout As New ControlLayout
closeButtonLayout.Bind Me, CloseButton, BottomAnchor + RightAnchor
Dim addButtonLayout As New ControlLayout
addButtonLayout.Bind Me, AddButton, RightAnchor + TopAnchor
Dim editButtonLayout As New ControlLayout
editButtonLayout.Bind Me, EditButton, RightAnchor
Dim showDetailsButtonLayout As New ControlLayout
showDetailsButtonLayout.Bind Me, ShowDetailsButton, RightAnchor
Dim deleteButtonLayout As New ControlLayout
deleteButtonLayout.Bind Me, DeleteButton, RightAnchor
Dim editKeyButtonLayout As New ControlLayout
editKeyButtonLayout.Bind Me, EditKeyButton, RightAnchor
Dim EditDateButtonLayout As New ControlLayout
EditDateButtonLayout.Bind Me, EditDateButton, RightAnchor
Dim EditDescriptionButtonLayout As New ControlLayout
EditDescriptionButtonLayout.Bind Me, EditDescriptionButton, RightAnchor
layoutBindings.Add closeButtonLayout, _
backgroundImageLayout, _
instructionsLabelLayout, _
itemsListLayout, _
addButtonLayout, _
editButtonLayout, _
showDetailsButtonLayout, _
deleteButtonLayout, _
editKeyButtonLayout, _
EditDateButtonLayout, _
EditDescriptionButtonLayout
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = True
Hide
End Sub
Private Sub UserForm_Resize()
Application.ScreenUpdating = False
If Me.width < minWidth Then Me.width = minWidth
If Me.height < minHeight Then Me.height = minHeight
Dim layout As ControlLayout
For Each layout In layoutBindings
layout.Resize Me
Next
Application.ScreenUpdating = True
End Sub
Public Property Get Model() As SqlResult
Set Model = this.Model
End Property
Public Property Set Model(ByVal value As SqlResult)
Set this.Model = value
OnModelChanged
End Property
Public Property Get SelectedItem() As SqlResultRow
Set SelectedItem = this.Selection
End Property
Public Property Set SelectedItem(ByVal value As SqlResultRow)
If (Not (value Is Nothing)) Then
If (ObjPtr(value.ParentResult) <> ObjPtr(this.Model)) Then
Set value.ParentResult = this.Model
End If
End If
Set this.Selection = value
EvaluateCanExecuteCommands
End Property
Private Sub EvaluateCanExecuteCommands()
AddButton.Enabled = this.Callback.CanExecute(AddCommand)
CloseButton.Enabled = this.Callback.CanExecute(CloseCommand)
DeleteButton.Enabled = this.Callback.CanExecute(DeleteCommand)
EditButton.Enabled = this.Callback.CanExecute(EditCommand)
ShowDetailsButton.Enabled = this.Callback.CanExecute(ShowDetailsCommand)
EditDateButton.Enabled = EditButton.Enabled
EditDescriptionButton.Enabled = EditButton.Enabled
EditKeyButton.Enabled = EditButton.Enabled
End Sub
Public Sub Initialize(cb As ICommandCallback, ByVal title As String, ByVal instructions As String, ByVal commands As ViewAction)
Localize title, instructions
Set this.Callback = cb
AddButton.Visible = commands And ViewAction.Create
EditButton.Visible = commands And ViewAction.Edit
DeleteButton.Visible = commands And ViewAction.Delete
ShowDetailsButton.Visible = commands And ViewAction.ShowDetails
EditKeyButton.Visible = commands And ViewAction.EditKey
EditDateButton.Visible = commands And ViewAction.EditDate
EditDescriptionButton.Visible = commands And ViewAction.EditDescription
If (commands And PowerEdit) = PowerEdit Then
EditButton.Top = AddButton.Top
Else
EditButton.Top = AddButton.Top + AddButton.height + 2
End If
End Sub
Private Sub Localize(ByVal title As String, ByVal instructions As String)
Me.Caption = title
InstructionsLabel.Caption = instructions
CloseButton.Caption = GetResourceString("CloseButtonText")
AddButton.ControlTipText = GetResourceString("AddButtonToolTip")
EditButton.ControlTipText = GetResourceString("EditButtonToolTip")
DeleteButton.ControlTipText = GetResourceString("DeleteButtonToolTip")
ShowDetailsButton.ControlTipText = GetResourceString("ShowDetailsButtonToolTip")
End Sub
Private Sub OnModelChanged()
ItemsList.Clear
If this.Model Is Nothing Then Exit Sub
this.Model.ValueSeparator = StringFormat("\t")
Dim row As SqlResultRow
For Each row In this.Model
Set row.ParentResult = this.Model
ItemsList.AddItem row.ToString
Next
End Sub
Private Sub ExecuteCommandInternal(method As CommandType)
If this.Callback Is Nothing Then Exit Sub
If this.Callback.CallbackOwner Is Nothing Then Exit Sub
this.Callback.Execute method
End Sub
Private Sub AddButton_Click()
ExecuteCommandInternal AddCommand
End Sub
Private Sub DeleteButton_Click()
ExecuteCommandInternal DeleteCommand
End Sub
Private Sub CloseButton_Click()
ExecuteCommandInternal CloseCommand
End Sub
Private Sub EditButton_Click()
ExecuteCommandInternal EditCommand
End Sub
Private Sub EditKeyButton_Click()
ExecuteCommandInternal EditKeyCommand
End Sub
Private Sub ShowDetailsButton_Click()
ExecuteCommandInternal ShowDetailsCommand
End Sub
Private Sub ItemsList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ExecuteCommandInternal EditCommand
End Sub
Private Sub ItemsList_Change()
If ItemsList.ListIndex >= 0 Then
Set SelectedItem = this.Model(ItemsList.ListIndex)
Else
Set SelectedItem = Nothing
End If
End Sub
Private Sub IView_Initialize(cb As ICommandCallback, ByVal title As String, ByVal instructions As String, ByVal commands As ViewAction)
Initialize cb, title, instructions, commands
End Sub
Private Property Get IView_CommandCallback() As ICommandCallback
Set IView_CommandCallback = this.Callback
End Property
Private Property Set IView_Model(ByVal value As SqlResult)
Set Model = value
End Property
Private Property Get IView_Model() As SqlResult
Set IView_Model = Model
End Property
Private Property Set IView_SelectedItem(ByVal value As SqlResultRow)
Set SelectedItem = value
End Property
Private Property Get IView_SelectedItem() As SqlResultRow
Set IView_SelectedItem = SelectedItem
End Property
Private Sub IView_Show()
Show
End Sub
Private Sub IView_Hide()
Hide
End Sub
Obviously you won't be able to use this code as-is without me writing an entire series of blog posts on the subject. But I hope it's enough to illustrate the approach.
Alternatively, you could go the easy way and have a Globals.bas module to share values between forms - there's a balance to achieve between doing it right and getting it done.