如何使用 Class 模块修改用户窗体标签的外观？

Question

我有这个用户窗体（图 1），我正在尝试通过 Class 模块应用一些自定义。因此，我的第一个目标是在单击时修改标签格式（图 2）。到目前为止一切顺利，我已经通过 Class 模块“cLabels”完成了这项工作。现在，我的第二个目标是（这是我坚持的目标）将一些其他颜色应用于上述标签。关键是，我不知道如何完成这个。

我试图创建另一个名为“cUserForm”的 class 模块，但我不知道如何将修改后的标签传递给 cUserForm Class 模块并使用其 MouseMove 事件。我知道我可以使用 MouseMove 事件通过标准用户窗体模块应用修改，但问题是，我不想在我的用户窗体模块中使用任何类似的代码，我希望 class 模块执行“脏”工作。大家有什么想法可以解决这个问题吗？

附加信息（但对解决问题不重要）：我的最终目标是制作像这样的“按钮”https://drive.google.com/file/d/1ev_LNgxPqjMv0dtzlF7GSo7SOq0wDbR2/view?usp=sharing，具有一些效果，例如 MouseHover、TabPress 等。 VBA 按钮非常难看。仅作记录，我已经在标准用户窗体模块中完成了所有这些工作（如果有人想让工作簿看到我在说什么，我有），但最终结果只是一团糟，代码太多（并且它只是修改用户窗体外观的代码，想象一下当我放一些代码来执行某些操作时，我的天啊）。

Image 1

Image 2

这是我目前的情况：

用户窗体模块

Option Explicit

Private ObjLabel As cLabels
Private ObjUserForm As cUserForm

Private Sub UserForm_Initialize()

 Set ObjLabel = New cLabels
 ObjLabel.CallClasse Me
 
 Set ObjUserForm = New cUserForm
 Set ObjUserForm.UserFormValue = Me
 
End Sub

c标签

Option Explicit

'## Events/Variables/Collections
Private WithEvents clsLabel As MSForms.Label

Private ClasseObject As cLabels
Private LabelCollection As New Collection

'## Properties
Public Property Get ActiveLabel() As MSForms.Label
    Set ActiveLabel = clsLabel
End Property

Public Property Set ActiveLabel(Value As MSForms.Label)
    Set clsLabel = Value
End Property

'## Procedures/Methods
Private Sub clsLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
 LabelHovered
End Sub

Public Sub CallClasse(MainObject As MSForms.UserForm)

 Dim ctrl As MSForms.Control

 For Each ctrl In MainObject.Controls

    If TypeOf ctrl Is MSForms.Label Then
        Set ClasseObject = New cLabels
        Set ClasseObject.ActiveLabel = ctrl
        LabelCollection.Add ClasseObject
    End If

 Next ctrl

End Sub

Private Sub LabelHovered()
 ActiveLabel.BackColor = vbYellow
End Sub

cUserForm

Option Explicit

'## Events/Variables/Collections
Private WithEvents clsUserForm As MSForms.UserForm
Private mActiveLabel As MSForms.Label
Private ObjLabel As New cLabels

'## Properties
Public Property Get UserFormValue() As MSForms.UserForm
    Set UserFormValue = clsUserForm
End Property

Public Property Set UserFormValue(Value As MSForms.UserForm)
    Set clsUserForm = Value
End Property

Public Property Get ActiveLabel() As MSForms.Label
    Set ActiveLabel = mActiveLabel
End Property

Public Property Set ActiveLabel(Value As MSForms.Label)
    Set mActiveLabel = Value
End Property

'## Procedures
Private Sub clsUserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'MsgBox ObjLabel.ActiveLabel.BackColor 'Got an error
End Sub

工作簿： https://drive.google.com/file/d/1cLG4pLmC-jDaysjd_dK0EFuJ_LqYqJ-u/view?usp=sharing

Answer 1

您无需创建单独的 class 模块来更改表单中的内容。只需在表单后面的代码中添加事件处理方法。（在表单编辑器中，右键单击表单并select“查看代码”。）

您可以使用按钮的 MouseMove 事件更改其颜色，然后使用表单的 MouseMove 事件重置按钮颜色，如下所示：

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

    CommandButton1.BackColor = &H8000000F
End Sub

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

    CommandButton1.BackColor = vbYellow
End Sub

Answer 2

我发现您的问题非常有趣，并且我对如何执行此操作有一些不同的、更面向对象的看法。我尝试实施 Observer Pattern 以获得所描述的效果。 （作为旁注，通常我会使用接口来概括一个解决方案，但对于这个快速演示，我将展示几个紧密耦合的类来完成工作）

请允许我先介绍一下我的所有组件：

类:

LabelObserver

Option Explicit

Private WithEvents mInteralObj As MSForms.label
Private mBackGroundColor As Long
Private mMouseOverColor As Long

Private Const clGREY As Long = &H8000000F

'// "Constructor"
Public Sub Init(label As MSForms.label, _
                Optional mouseOverColor As Long = clGREY, _
                Optional backGroundColor As Long = clGREY)
                
    Set mInteralObj = label
    mBackGroundColor = backGroundColor
    mMouseOverColor = mouseOverColor
End Sub

Private Sub Class_Terminate()
    Set mInteralObj = Nothing
End Sub

Public Sub MouseLeft()
    '//Remove Highlight
    mInteralObj.BackColor = mBackGroundColor
End Sub

Private Sub mInteralObj_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    '//Highlight
    mInteralObj.BackColor = mMouseOverColor
End Sub

LabelNotifier

Option Explicit
Private observersCollection As Collection

Private Sub Class_Initialize()
    Set observersCollection = New Collection
End Sub

Public Sub AddObserver(observer As LabelObserver)
    observersCollection.Add observer
End Sub

Public Sub RemoveObserver(observer As LabelObserver)
    Dim i As Long
    '// We have to search through the collection to find the observer to remove
    For i = 1 To observersCollection.Count
        If observersCollection(i) Is observer Then
            observersCollection.Remove i
            Exit Sub
        End If
    Next i
End Sub

Public Function ObserverCount() As Integer
    ObserverCount = observersCollection.Count
End Function

Public Sub Notify()
    Dim obs As LabelObserver
    
    If Me.ObserverCount > 0 Then
    
        For Each obs In observersCollection
            '//call each observer's MouseLeft method
            obs.MouseLeft
        Next obs
    
    End If
End Sub

Private Sub Class_Terminate()
    Set observersCollection = Nothing
End Sub

模块：

LabelObserverFactory （这是可选的 - 它只是提供了一种创建有效 LabelObservers 的精简方式）

Option Explicit

Public Function NewYellowHighlightCustomLabel(label As MSForms.label) As LabelObserver
    Dim product As New LabelObserver
    
    product.Init label, vbYellow
    
    Set NewYellowHighlightCustomLabel = product
End Function

Public Function NewRedHighlightCustomLabel(label As MSForms.label) As LabelObserver
    Dim product As New LabelObserver
    
    product.Init label, vbRed
    
    Set NewRedHighlightCustomLabel = product
End Function

用户窗体

MyForm （请注意，为了演示目的，此表单具有三个带有默认名称的标签）

Option Explicit

Private notifier As LabelNotifier


Private Sub UserForm_Initialize()
    Set notifier = New LabelNotifier
    
    '//add controls to be notified
    notifier.AddObserver LabelObserverFactory.NewYellowHighlightCustomLabel(Me.Label1)
    notifier.AddObserver LabelObserverFactory.NewRedHighlightCustomLabel(Me.Label2)
    notifier.AddObserver LabelObserverFactory.NewYellowHighlightCustomLabel(Me.Label3)
    
    
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    '//Notify labels that mouse has left them
    notifier.Notify
End Sub

Private Sub UserForm_Terminate()
    Set notifier = Nothing
End Sub

现在，解释一下这里发生了什么：

表单有一个 LabelNotifier 对象，它在表单初始化时建立，它将用来通知我们的标签鼠标已经离开它们。我们通过侦听窗体的 MouseMove 事件来完成此操作。 （我知道你试图避免使用这个，但希望我们的代码只有一行代码，无论你影响多少标签，都能满足在别处封装逻辑的愿望。） 当我们移动鼠标时，我们会让通知程序做它唯一的工作，向我们添加的所有标签发送消息。

LabelObserver 是 LabelNotifier 的对应部分。标签观察员负责告诉标签更改颜色以及使用哪种颜色。

即使您不喜欢这个实现，我也乐在其中。 :-)

如何使用 Class 模块修改用户窗体标签的外观？

How to modify the appearance of UserForm Labels using Class Module?

vba

vba7

vba6