excel - Excel VBA用户窗体动态运行时控件-跨多个控件触发同一类事件

我正在构建一个基于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：


lblMenuBackground
lblMenuIcon
lblMenuText


...并异步构建它们。

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

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

cMenuItem类模块中的代码

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图标。）

因为我已向每个MouseOver标签添加了自定义lblMenuBackground类事件，所以将鼠标悬停会导致.BackColor更改：



这是我的问题...

仅当光标经过组成每个菜单项的三个标签之一时，才触发鼠标悬停效果。

lblMenuBackground

为什么？

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

更确切地说...

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

这是每个菜单项的结构：



这是我的问题...



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


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


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

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

...针对每个菜单项。

End子Question

__________

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

对于那些到目前为止取得成功的人-感谢您的阅读！

任何帮助表示赞赏。

谢谢，

J先生

最佳答案

您正在关注lblMenuBackground的事件

lbl（i）.lblEvent1 = lblMenuBackground

修改BuildMenuItems
更改

设置lbl（i）.lblEvent1 = lblMenuBackground

至

设置lbl（i）= New cMenuItem
lbl（i）.setControls lblMenuBackground，lblMenuIcon，lblMenuText

修改CMenuItem类

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 - Excel VBA用户窗体动态运行时控件-跨多个控件触发同一类事件，我们在Stack Overflow上找到一个类似的问题：https://stackoverflow.com/questions/41174741/