Excel VBA 用户窗体动态运行时控件 - 跨多个控件触发相同的 Class 事件

Question

我正在构建一个基于 Excel 的应用程序，它会根据外部数据在运行时间动态构建自己。

这是空的用户表单：

UserForm_Activate()

内的代码

Private Sub UserForm_Activate()
Dim f As Control, i As Integer

mdMenuItems.BuildMenuItems
mdTheme.GetTheme

For Each f In Me.Controls
    If TypeName(f) = "Frame" Then
        i = i + 1
        ReDim Preserve fra(1 To i)
        Set fra(i).fraEvent1 = f
    End If
Next f

End Sub

mdMenuItems.BuildMenuItems 根据外部数据动态构建一系列菜单项...

mdMenuItems 模块中的代码

Option Explicit
Dim lbl() As New cMenuItem
Public myFileData As String
Public myFileValue As String
Public frmTheme As String

Sub BuildMenuItems()
Dim FileNum As Integer, i As Integer
Dim WrdArray() As String
Dim lblMenuIcon As MSForms.Label, lblMenuText As MSForms.Label, lblMenuBackground As MSForms.Label

FileNum = FreeFile()

Open Application.ThisWorkbook.Path & "\Data\MenuItems.csv" For Input As #FileNum

Do While Not EOF(FileNum)
    i = i + 1
    Line Input #FileNum, myFileData ' read in data 1 line at a time
    WrdArray() = Split(myFileData, ",")
    Set lblMenuBackground =  frmTest.frmMenuBackground.Controls.Add("Forms.Label.1", "lblMenuBackground_" & i)
    Set lblMenuIcon = frmTest.frmMenuBackground.Controls.Add("Forms.Label.1", "lblMenuIcon_" & i)
    Set lblMenuText = frmTest.frmMenuBackground.Controls.Add("Forms.Label.1", "lblMenuText_" & i)

    With lblMenuBackground
        .top = 30 * i
        .left = 0
        .Width = 170
        .Height = 30
        .BackColor = RGB(255, 255, 255)
        .BackStyle = fmBackStyleOpaque
        .MousePointer = fmMousePointerCustom
        .MouseIcon = LoadPicture(Application.ThisWorkbook.Path & "\Creative\Other\Hand.cur")
        .Tag = "_006"
    End With

    ReDim Preserve lbl(1 To i)
    Set lbl(i).lblEvent1 = lblMenuBackground

    With lblMenuIcon
        .Caption = Sheets("FontAwesome").Cells(WrdArray(0), 1)
        .top = (30 * i) + 9
        .left = 0
        .Width = 30
        .Height = 20
        .ForeColor = RGB(0, 0, 0)
        .BackStyle = fmBackStyleTransparent
        .Font.Name = "FontAwesome"
        .Font.Size = 14
        .TextAlign = fmTextAlignCenter
        .MousePointer = fmMousePointerCustom
        .MouseIcon = LoadPicture(Application.ThisWorkbook.Path & "\Creative\Other\Hand.cur")
        .Tag = "-021"
    End With

    With lblMenuText
        .Caption = WrdArray(1)
        .top = (30 * i) + 8
        .left = 30
        .Width = 90
        .Height = 20
        .ForeColor = RGB(0, 0, 0)
        .BackStyle = fmBackStyleTransparent
        .Font.Size = 12
        .MousePointer = fmMousePointerCustom
        .MouseIcon = LoadPicture(Application.ThisWorkbook.Path & "\Creative\Other\Hand.cur")
        .Tag = "-021"
    End With

Loop

Close #FileNum

End Sub

好的，所以简要概述一下这里发生的事情...

我打开了一个数据文件MenuItems.csv用于输入。我将此文件中的每一行分配给 i。我然后Set三个人MSForms.Label(s):

lblMenuBackground
lblMenuIcon
lblMenuText

...并异步构建它们。

您会注意到，在构建第一个标签 (lblMenuBackground) 之后，我分配了一个自定义 class 事件 lbl(i).lblEvent1 = lblMenuBackground.

（我在这里正确使用 ReDim Preserve 很重要，这样每个顺序菜单项都会获得此自定义 class，而不仅仅是最后一个。）

cMenuItemclass 模块中的代码

Public WithEvents lblEvent1 As MSForms.Label

Private Sub lblEvent1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

Dim ctl As Control
    For Each ctl In frmTest.frmMenuBackground.Controls
        If TypeName(ctl) = "Label" Then
            If Not ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6)) Then ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6))
        End If
    Next ctl

Me.lblEvent1.BackColor = RGB(GetB(mdTheme.frmThemeID2), GetG(mdTheme.frmThemeID2), GetR(mdTheme.frmThemeID2))

End Sub

（请忽略这里的 .BackColor 属性复杂性，因为它可能甚至令人困惑，并且与这个问题。）

在 UserForm_Activate 之后，这是更新后的表格：

（您可能会注意到此处使用了 FontAwesome 图标。）

因为我为每个 lblMenuBackground 标签添加了自定义 MouseOver class 事件，鼠标悬停会导致 .BackColor 发生变化：

这是我的问题...

只有当光标经过构成每个菜单项的三个标签之一时才会触发此鼠标悬停效果。

lblMenuBackground

为什么？

我只知道如何影响被调用控件的属性。

或者更确切地说...

我不知道如何从被调用控件的事件中影响未调用的控件属性。

每个菜单项的结构如下：

这是我的问题...

如何从构成每个菜单项的所有三个单独控件的 MouseOver 事件影响同一控件的 .BackColor？

将光标移到图标上 = 背景颜色更改
将光标移到文本上 = 背景颜色更改
将光标移到背景上 = 背景颜色改变

需要在构建时分配 class 事件...

ReDim Preserve lbl(1 To i)
Set lbl(i).lblEvent1 = lblMenuBackground

...对于每个菜单项。

End子Question

__________

这个逻辑将从根本上为我的界面奠定基础。

对于那些已经走到这一步的人 - 感谢您的阅读！

感谢任何帮助。

谢谢，

先生J

Answer 1

您正在连接 lblMenuBackground

的活动

lbl(i).lblEvent1 = lblMenuBackground

修改 BuildMenuItems

改变

Set lbl(i).lblEvent1 = lblMenuBackground

到

Set lbl(i) = New cMenuItem

lbl(i).setControls lblMenuBackground, lblMenuIcon, lblMenuText

修改CMenuItem Class

Public WithEvents m_lblMenuBackground As MSForms.Label
Public WithEvents m_lblMenuIcon As MSForms.Label
Public WithEvents m_lblMenuText As MSForms.Label

Public Sub setControls(lblMenuBackground As MSForms.Label, lblMenuIcon As MSForms.Label, lblMenuText As MSForms.Label)
    Set m_lblMenuBackground = lblMenuBackground
    Set m_lblMenuIcon = lblMenuIcon
    Set m_lblMenuText = lblMenuText
End Sub
    
Private Sub m_lblMenuBackground_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Update
End Sub

Private Sub m_lblMenuIcon_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Update
End Sub

Private Sub m_lblMenuText_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Update
End Sub

Private Sub Update()
    Dim ctl As Control
    For Each ctl In frmTest.frmMenuBackground.Controls
        If TypeName(ctl) = "Label" Then
            If Not ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6)) Then ctl.BackColor = RGB(GetB(mdTheme.frmThemeID6), GetG(mdTheme.frmThemeID6), GetR(mdTheme.frmThemeID6))
        End If
    Next ctl

    Me.m_lblMenuBackground.BackColor = RGB(GetB(mdTheme.frmThemeID2), GetG(mdTheme.frmThemeID2), GetR(mdTheme.frmThemeID2))
End Sub

Excel VBA 用户窗体动态运行时控件 - 跨多个控件触发相同的 Class 事件

Excel VBA Userform Dynamic Runtime Controls - Trigger Same Class Event Across Multiple Controls

excel

user-controls

vba

runtime

dynamic

这是我的问题...

为什么？

这是我的问题...

__________

修改 BuildMenuItems

修改CMenuItem Class