从第4种形式引用子表单的子表单

Question

我已经尝试过来自许多不同网站的所有建议，但它们都不起作用，甚至不是Microsoft的KB文章或Stack Overflow中建议的参考文献。

我有一个主窗体[frmMain]，有一个名为[frmTaskTracking]的子窗体和一个名为[sfmActivites子窗体]的子窗体中的子窗体。我需要从弹出窗体[frmExportTasks]获取[sfmActivites子窗体]的过滤器，该窗体从[frmTaskTracking]打开，如下所示：

[frmMain]
  [frmTaskTracking]
    [sfmActivites subform]
      Filter
[frmExportTasks]

在VBA中引用[sfmActivites子表单]格式的过滤器的正确方法是什么？

非常感谢！

Answer 1

您的问题非常概念，因此此答案可能适用于您的特定问题，也可能不适用。

我曾经不得不创建一个涉及master-detail数据的CRUD应用程序，我不得不在Excel VBA中执行它，并且无法访问数据库...所以我编写了针对抽象的代码< / em>并实现了 Model-View-Presenter ， Command 和 Repository + UnitOfWork 模式...... 可能 稍微过度满足您的需求。

然而，这个解决方案有点过分，它与VBA一样具有SOLID，并且允许我为我想要使用的每个“主”和“详细信息”表重用相同的表单/视图 - 再次，关于你正在做什么，你的帖子并不十分清晰，所以我只是要揭示对我有用的解决方案。它是正确的方式吗？取决于你在做什么。这对我来说是正确的方式，因为我可以使用模拟数据测试整个功能，当我到办公室并将工作单元换成实际连接到数据库的工作单元时，所有只是工作

关键是 Presenter 知道其 MasterId 及其 DetailsPresenter （如果有的话）：

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

假设我有一个CategoriesPresenter和一个SubCategoriesPresenter，我可以像这样执行CategoriesPresenter：

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

SubCategoriesPresenter看起来像这样：

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

在你的情况下，你可以在这里获得DetailsPresenter，并且该孩子也有自己的DetailsPresenter实例。

对我来说最难的是实施命令。这可能会有所帮助：

的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

这使我能够完全在视图之外，并进入演示者。

以下是我的表单的代码隐藏：

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

显然，如果没有我就此主题撰写一系列博客文章，您将无法使用此代码。但我希望这足以说明这种方法。

或者，您可以轻松地使用Globals.bas模块在​​表单之间共享值 - 在正确执行和完成表单之间实现平衡< / em>的