VBA UserForm_初始化合并悬停效果

Question

我有一个 UserForm1，有 UserForm_Initialize，我在其中定义所有标签属性，如下所示。我还有一个可以实现悬停效果的代码，请参阅代码 2. 块。

UserForm_初始化代码：

Sub UserForm1_Initialize()

'.... my code

    Dim ctrl As MSForms.Control
    Dim index As Integer
    
    index = 1 ' Startindex für die Labels
    
    For Each ctrl In UserForm1.Controls
        If TypeOf ctrl Is MSForms.label Then 'And ctrl.Tag = "LabelAlignmentTheme" Then
            Dim label As MSForms.label
            Set label = ctrl
            Set label.Picture = UserForm1.GIF.Picture 'read the picture from the picture control
            label.PicturePosition = fmPicturePositionLeftCenter

        End If
    Next
    
    For Each ctrl In UserForm1.Controls
        If TypeName(ctrl) = "Label" Then
                With ctrl
                    .FontSize = 10
                    .FontName = "Calibri"
                    .ForeColor = &H464646    '(Dark Gray)
                    .BackColor = RGB(255, 255, 255)  '(weiß)
                    .BorderStyle = fmBorderStyleSingle
                    .BorderColor = &HA9A9A9    '(Light Gray)
                    .TextAlign = fmTextAlignCenter
                    If .Name = "LabelNoData" Then
                        .ForeColor = RGB(255, 0, 0)
                        .FontBold = True 
                        .BorderStyle = fmBorderStyleNone
                        .FontSize = 12
                        .BackColor = &H8000000F 
                        .Visible = False
                    End If
                End With
        End If
    Next ctrl
End Sub

悬停效果代码：

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If active = False Then
        Label1.BackColor = RGB(204, 255, 229) 'blue green
        active = True
    End If
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If active = True Then
        Label1.BackColor = RGB(255, 255, 255) 'weiß
        active = False
    End If
End Sub

我尝试了什么以及我期待什么？：

我尝试合并这两个代码，意味着所有创建的按钮也应该具有悬停效果，但尝试后我无法做到这一点。

合并代码：

Sub UserForm1_Initialize()

'.... my code

    Dim ctrl As MSForms.Control
    Dim index As Integer
    
    index = 1 ' Startindex für die Labels
    
    For Each ctrl In UserForm1.Controls
        If TypeOf ctrl Is MSForms.label Then 'And ctrl.Tag = "LabelAlignmentTheme" Then
            Dim label As MSForms.label
            Set label = ctrl
            Set label.Picture = UserForm1.GIF.Picture 'read the picture from the picture control
            label.PicturePosition = fmPicturePositionLeftCenter

        End If
    Next
    
    For Each ctrl In UserForm1.Controls
        If TypeName(ctrl) = "Label" Then
                With ctrl
                    .FontSize = 10
                    .FontName = "Calibri"
                    .ForeColor = &H464646    '(Dark Gray)
                    .BackColor = RGB(255, 255, 255)  '(weiß)
                    .BorderStyle = fmBorderStyleSingle
                    .BorderColor = &HA9A9A9    '(Light Gray)
                    .TextAlign = fmTextAlignCenter
                    UserForm_MouseMove 'here for merge
                    Label_MouseMove 'here for merge
                    If .Name = "LabelNoData" Then
                        .ForeColor = RGB(255, 0, 0)
                        .FontBold = True 
                        .BorderStyle = fmBorderStyleNone
                        .FontSize = 12
                        .BackColor = &H8000000F 
                        .Visible = False
                    End If
                End With
        End If
    Next ctrl
End Sub

鼠标悬停：

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Not activeLabel Is Nothing Then
        activeLabel.BackColor = RGB(255, 255, 255) 'weiß
        Set activeLabel = Nothing
    End If
End Sub

Private Sub Label_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If TypeName(Me.ActiveControl) = "Label" Then
        If Not activeLabel Is Nothing Then
            activeLabel.BackColor = RGB(255, 255, 255) 'weiß
        End If
        Set activeLabel = Me.ActiveControl
        activeLabel.BackColor = RGB(204, 255, 229) 'blue green
    End If
End Sub

Answer 1

这是一个例子：

clsLbl事件：

Option Explicit

Public WithEvents lbl As MSForms.Label

Private Sub lbl_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    HoverFormat True
End Sub

'set/unset "hover" format
Sub HoverFormat(bOn As Boolean)
    lbl.BackColor = IIf(bOn, RGB(204, 255, 229), vbWhite)
End Sub

用户表单：

Option Explicit

Dim col As Collection 'stores instances of `clsLblEvent`

Private Sub UserForm_Activate()
    Dim ctrl As Object
    Set col = New Collection
    
    For Each ctrl In Me.Controls 'use `Me`
        If TypeName(ctrl) = "Label" Then
            '...
            'do your formatting...
            '...
        
        
            col.Add getEventObject(ctrl) 'initialize event capture
        End If
    Next ctrl
    
End Sub

'return an instance of clsLblEvent
Function getEventObject(lbl As MSForms.Label) As clsLblEvent
    Set getEventObject = New clsLblEvent
    Set getEventObject.lbl = lbl
    getEventObject.HoverFormat False 'hover off
End Function


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim obj
    For Each obj In col 'set all labels' hover format to off
        obj.HoverFormat False
    Next obj
End Sub