reference subform of subform from 4th form

1
votes

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!

1
formsvba
You can always store a global reference and get it that way... If not that, then what have you tried so far? Every suggestion from everywhere doesn't help us identify why those suggestions may not have worked. – Byron Wall
How are you opening this "popup" form? Are you creating an instance of it via code, or are you calling DoCmd? Let's see a bit of code so we can help you out. – RubberDuck
Oh, ...if that's Access-VBA, please tag the question as such. – Mathieu Guindon
I solved it by finally referencing the third form correctly with its Filter property, using a fully qualified reference from the Main form down to the third subform. Plus I saved the Filter and tested it for no value, or empty string – Eikon Rahu

1 Answers

1
votes

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.