excel中从右到左的用户表单 - VBA

Question

请看下面的代码并测试一下：

Private Sub CommandButton1_Click()
   MsgBox "This window converted Right to Left!", vbMsgBoxRtlReading
End Sub

此代码将消息窗口从右向左转换。随着关闭按钮移动到窗口的左侧。我如何为用户表单执行此操作？ （希望 T.M.、Mathieu Guindon 和...不要说：“您的问题有问题。请阅读链接...。”）

如下图（当然照片是photoshop！）：

Answer 1

模拟从右到左显示，如MsgBox

有必要使用一些 API *) 函数从语言设置中获取所需的布局独立，默认使用从右到左的功能。

1. 识别用户表单的句柄以访问更多 API 方法
2. 删除用户窗体的标题栏
3. 替换它，例如带有显示标题的 Label 控件，并为其提供拖动功能以移动用户窗体（此处：Label1）。

4. 使用另一个控件（这里：Label2）来模拟系统转义“x”。

   *) API - 应用程序编程接口

一个简单的用户窗体代码示例

您只需要提供 2 个标签控件，其中Label1 替换标题栏并接收用户窗体的标题，Label2 模拟系统 Escape "x"。此外，此示例使用Type 声明来轻松处理用户窗体句柄，以便为进一步的 API 操作需要它的多个事件过程。

► 2018 年 10 月 22 日第二次编辑的注释

由于窗口句柄在 Office 2010 或更高版本中被声明为 LongPtr 而在之前的版本中被声明为 Long，因此有必要通过条件编译常量来区分不同的版本（例如 #If VBA7 Then ... #Else ... #End If；参见第二节. 还使用Win64 常量来识别实际上安装的 64 位 Office 系统 - 请注意，Office 通常默认安装为 32 位）。

Option Explicit                 ' declaration head of userform code module

#If VBA7 Then                   ' compile constant for Office 2010 and higher
    Private Type TThis          ' Type declaratation
        frmHandle As LongPtr    ' receives form window handle 64bit to identify this userform
    End Type
#Else                           ' older versions
    Private Type TThis          ' Type declaratation
        frmHandle As Long       ' receives form window handle 32bit to identify this userform
    End Type
#End If
Dim this As TThis               ' this - used by all procedures within this module

Private Sub UserForm_Initialize()
' ~~~~~~~~~~~~~~~~~~~~~~~
' [1] get Form Handle
' ~~~~~~~~~~~~~~~~~~~~~~~
  this.frmHandle = Identify(Me) ' get UserForm handle via API call (Long)
' ~~~~~~~~~~~~~~~~~~~~~~~
' [2] remove System Title Bar
' ~~~~~~~~~~~~~~~~~~~~~~~
  HideTitleBar (this.frmHandle) ' hide title bar via API call
End Sub

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Purpose: Replaces System Title Bar (after removal via API) and receives dragging functionality
   ' ~~~~~~~~~~~~~~~~~~~~~~~~~~
   ' [3] allow to move UserForm
   ' ~~~~~~~~~~~~~~~~~~~~~~~~~~
     If Button = 1 Then DragForm this.frmHandle
End Sub

Private Sub Label2_Click()
' Purpose:  Label "x" replaces System Escape (after removal in step [2])and hides UserForm
' ~~~~~~~~~~~~~~~~~
' [4] hide UserForm
' ~~~~~~~~~~~~~~~~~
  Me.Hide
End Sub

Private Sub UserForm_Layout()
  Me.RightToLeft = True
' Simulated Escape Icon
  Me.Label2.Caption = " x"
  Me.Label2.BackColor = vbWhite
  Me.Label2.Top = 0
  Me.Label2.Left = 0
  Me.Label2.Width = 18: Me.Label2.Height = 18
' Simulated UserForm Caption
  Me.Label1.Caption = Me.Caption
  Me.Label1.TextAlign = fmTextAlignRight    ' <~~ assign right to left property
  Me.Label1.BackColor = vbWhite
  Me.Label1.Top = 0: Me.Label1.Left = Me.Label2.Width: Me.Label1.Height = Me.Label2.Height
  Me.Label1.Width = Me.Width - Me.Label2.Width - 4
End Sub

二。 API函数的独立代码模块

a) 带有常量和特殊 API 声明的声明头

有必要提供不同的应用程序版本，因为代码声明在某些参数中有所不同（例如 PtrSafe）。 64 位声明开头如下：Private Declare PtrSafe ...

还要注意通过 #If、#Else 和 #End If 进行的正确声明，允许版本相关的编译。

常量中使用的前缀&H代表十六进制值。

Option Explicit

Private Const WM_NCLBUTTONDOWN = &HA1&
Private Const HTCAPTION = 2&
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_CAPTION = WS_BORDER Or WS_DLGFRAME

#If VBA7 Then                                               ' True if you're using Office 2010 or higher
    ' [0] ReleaseCapture
    Private Declare PtrSafe Sub ReleaseCapture Lib "User32" ()
    ' [1] SendMessage
    Private Declare PtrSafe Function SendMessage Lib "User32" _
      Alias "SendMessageA" _
      (ByVal hWnd As LongPtr, ByVal wMsg As Long, _
      ByVal wParam As LongPtr, lParam As Any) As LongPtr    ' << arg's hWnd, wParam + function type: LongPtr
    ' [2] FindWindow
    Private Declare PtrSafe Function FindWindow Lib "User32" _
            Alias "FindWindowA" _
           (ByVal lpClassName As String, _
            ByVal lpWindowName As String) As LongPtr        ' << function type: LongPtr
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Two API functions requiring the Win64 compile constant for 64bit Office installations
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    #If Win64 Then                                          ' true if Office explicitly installed as 64bit
      ' [3a] Note that GetWindowLong has been replaced by GetWindowLongPtr
        Private Declare PtrSafe Function GetWindowLongPtr Lib "User32" _
            Alias "GetWindowLongPtrA" _
           (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long) As LongPtr
      ' [3b] Note that GetWindowLong has been replaced by GetWindowLongPtr
      '      Changes an attribute of the specified window.
      '      The function also sets a value at the specified offset in the extra window memory.
        Private Declare PtrSafe Function SetWindowLongPtr Lib "User32" _
            Alias "SetWindowLongPtrA" _
           (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As LongPtr) As LongPtr
    #Else                                                   ' true if Office install defaults 32bit
      ' [3aa] Note that GetWindowLong has been replaced by GetWindowLongPtr Alias GetWindowLongA !
        Private Declare PtrSafe Function GetWindowLongPtr Lib "User32" _
            Alias "GetWindowLongA" _
           (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long) As LongPtr
      ' [3bb] Note that GetWindowLong has been replaced by GetWindowLongPtr Alias SetWindowLongA !
        Private Declare PtrSafe Function SetWindowLongPtr Lib "User32" _
            Alias "SetWindowLongA" _
           (ByVal hWnd As LongPtr, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As LongPtr) As LongPtr

    #End If

    ' [4] DrawMenuBar
    Private Declare PtrSafe Function DrawMenuBar Lib "User32" _
           (ByVal hWnd As LongPtr) As Long                  ' << arg hWnd: LongPtr

#Else                                                       ' True if you're using Office before 2010 ('97)

    Private Declare Sub ReleaseCapture Lib "User32" ()
    Private Declare Function SendMessage Lib "User32" _
          Alias "SendMessageA" _
          (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

    Private Declare Function FindWindow Lib "User32" _
            Alias "FindWindowA" _
           (ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long


    Private Declare Function GetWindowLong Lib "User32" _
            Alias "GetWindowLongA" _
           (ByVal hWnd As Long, _
            ByVal nIndex As Long) As Long

    Private Declare Function SetWindowLong Lib "User32" _
            Alias "SetWindowLongA" _
           (ByVal hWnd As Long, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As Long) As Long

    Private Declare Function DrawMenuBar Lib "User32" _
           (ByVal hWnd As Long) As Long
#End If

b) 遵循程序（a 部分之后）

' ~~~~~~~~~~~~~~~~~~~~~~
' 3 Procedures using API
' ~~~~~~~~~~~~~~~~~~~~~~

#If VBA7 Then                               ' Office 2010 and higher
    Public Function Identify(frm As Object) As LongPtr
    ' Purpose: [1] return window handle of form
    ' Note:    vbNullString instead of ThunderXFrame (97) and class names of later versions
      Identify = FindWindow(vbNullString, frm.Caption)
    End Function

    Public Sub HideTitleBar(hWnd As LongPtr)
    ' Purpose: [2] remove Userform title bar
      SetWindowLongPtr hWnd, GWL_STYLE, GetWindowLongPtr(hWnd, GWL_STYLE) And Not WS_CAPTION
    End Sub
        Public Sub ShowTitleBar(hWnd As LongPtr)
        ' Purpose: show Userform title bar
          SetWindowLongPtr hWnd, GWL_STYLE, GetWindowLongPtr(hWnd, GWL_STYLE) Or WS_CAPTION
        End Sub

    Public Sub DragForm(hWnd As LongPtr)
    ' Purpose: [3] allow to drag & move userform via control (here via e.g.: Label1)
      Call ReleaseCapture
      Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End Sub

#Else                                       ' vers. before Office 2010 (Office '97)
    Public Function Identify(frm As Object) As Long
    ' Purpose: [1] return window handle of form
    ' Note:    vbNullString instead of ThunderXFrame (97) and class names of later versions
      Identify = FindWindow(vbNullString, frm.Caption)
    End Function
    Public Sub HideTitleBar(hWnd As Long)
    ' Purpose: [2] remove Userform title bar
      SetWindowLong hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) And Not WS_CAPTION
    End Sub
    '    Public Sub ShowTitleBar(HWND As Long)
    '    ' Purpose: show Userform title bar
    '      SetWindowLong HWND, GWL_STYLE, GetWindowLong(HWND, GWL_STYLE) Or WS_CAPTION
    '    End Sub

    Public Sub DragForm(hWnd As Long)
    ' Purpose: [3] allow to drag & move userform via control (here via e.g.: Label1)
      Call ReleaseCapture
      Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End Sub


#End If

► 警告： API 声明未针对实际在 Office 2010 或更高版本中安装的 64 位系统进行测试。第二次编辑为2018 年 10 月 22 日 尝试更正几个 LongPtr 声明（仅适用于指向 → 句柄或 → 内存位置的指针）并使用当前的 Get/SetWindowLongPtr 函数明确区分 Win64 和 Win32；参看。还在 UserForm 代码模块的声明头中编辑了 Type 声明）。

另请参阅Compatibility between 32bit and 64bit Versions of Office 2010 和 Office 2010 Help Files: Win32API PtrSafe with 64bit Support

补充说明

用户窗体是 Windows，可以通过它们的窗口句柄来识别。 用于此目的的 API 函数是 FindWindow 处理两个参数： 1) 一个字符串，它给出了它需要查找的窗口的类的名称和 2) 一个字符串，给出了它需要查找的窗口 (UserForm) 的 caption。

因此，人们经常将版本 '97（UserForm 类名“ThunderXFrame”）和更高版本（“ThunderDFrame”）区分开来：

 If Val(Application.Version) < 9 Then 
    hWnd = FindWindow("ThunderXFrame", frm.Caption)   ' if used within Form: Me.Caption
 Else   ' later versions
    hWnd = FindWindow("ThunderDFrame", frm.Caption)   ' if used within Form: Me.Caption
 End If 

然而，使用vbNullString（和独特的字幕！）反而让编码更容易：

 hWnd = FindWindow(vbNullString, frm.Caption)         ' if used within Form: Me.Caption

推荐阅读

UserForm 代码模块实际上是类，应该这样使用。所以我推荐阅读 M. Guindon 的文章UserForm1.Show。 - 可能有一些兴趣，Destroy a modeless UserForm instance properly