创建可调大小的用户窗体——使用VBA

fanjy

发布于 2023-08-29 21:12:06

8720

发布于 2023-08-29 21:12:06

文章被收录于专栏：完美Excel

标签：VBA

在上篇文章：创建可调大小的用户窗体——使用Windows API中，我们使用Windows API实现了允许用户可以调整用户窗体的大小。本文仅使用VBA来实现同样的效果。

本文的代码整理自exceloffthegrid.com，供有兴趣的朋友参考。

VBA解决方案：用户窗体包含一个对象，单击该对象时会记录鼠标的位置；随着鼠标的移动，用户窗体及其对象将根据新的鼠标位置重新定位或调整大小；当释放鼠标按钮时，停止移动以调整大小。

示例用户窗体

在VBE中，插入一个用户窗体，如下图1所示。

图1

其中，放置了三个元素：一个名为lstListBox的列表框，一个名为cmdClose的命令按钮，一个名为lblResizer的标签。

标签lblResizer的设置如下图2所示，标题为字符“y”并设置Wingdings 3字体，使之以小三角的形式显示在窗体右下角，让用户在此单击以调整窗体大小。

图2

在用户窗体代码模块中，输入下面的代码：

Private resizeEnabled As Boolean
Private mouseX As Double
Private mouseY As Double
Private minWidth As Double
Private minHeight As Double

Private Sub UserForm_Initialize()
 '定位调整大小图标
 lblResizer.Left = Me.InsideWidth - lblResizer.Width
 lblResizer.Top = Me.InsideHeight - lblResizer.Height
 minHeight = 125
 minWidth = 125
End Sub

下面的代码在鼠标单击lblResizer图标时触发，记录了单击图标及当时鼠标的位置。

Private Sub lblResizer_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
 ByVal X As Single, ByVal Y As Single)
 '用户在lblResizer上单击
 resizeEnabled = True
 '捕获单击时鼠标位置
 mouseX = X
 mouseY = Y
End Sub

下面的代码在鼠标移动到lblResizer标签图标上时触发。

首先，它将检查窗口是否大于允许的最小大小，以及鼠标是否已被单击。如果两者都为True，则会根据鼠标移动的大小重新定位或调整UserForm和对象的大小。

Private Sub lblResizer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
 ByVal X As Single, ByVal Y As Single)
 '检查用户窗体的大小是否调整得太小
 Dim allowResize As Boolean
 allowResize = True
 If Me.Width + X - mouseX < minWidth Then allowResize = False
 If Me.Height + Y - mouseY < minHeight Then allowResize = False
 '检查鼠标是否单击了lblResizer并超过了最小大小
 If resizeEnabled = True And allowResize = True Then
   '根据单击后的鼠标移动调整/移动对象
   '调整用户窗体大小
   Me.Width = Me.Width + X - mouseX
   Me.Height = Me.Height + Y - mouseY
   '调整列表框大小
   lstListBox.Width = lstListBox.Width + X - mouseX
   lstListBox.Height = lstListBox.Height + Y - mouseY
   '移动关闭按钮
   cmdClose.Left = cmdClose.Left + X - mouseX
   cmdClose.Top = cmdClose.Top + Y - mouseY
   '移动标签图标
   lblResizer.Left = Me.InsideWidth - lblResizer.Width
   lblResizer.Top = Me.InsideHeight - lblResizer.Height
 End If
End Sub

下面的代码在释放鼠标时触发，鼠标移动停止以调整UserForm的大小。

Private Sub lblResizer_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
 ByVal X As Single, ByVal Y As Single)
 '用户取消单击标签lblResizer
 resizeEnabled = False
End Sub

运行用户窗体，效果如下图3所示。