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

请查看下面的代码并进行测试：

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

此代码将消息窗口从右到左转换。当关闭按钮移至窗口左侧时。我该如何针对用户表单？
（希望T.M.，Mathieu Guindon和...不会说：“您的问题不对。请阅读链接....”）

就像下面的图片（当然照片是photoshop！）：

最佳答案

在MsgBox中模拟从右到左的显示

必须使用一些API *）函数来获得所需的布局，而默认情况下使用右至左功能可以使其与语言设置无关。


确定用户窗体的句柄以访问其他API方法
删除用户窗体的标题栏
更换它例如带有显示标题的Label控件，并为其提供拖动功能以移动UserForm（此处为Label1）。
使用另一个控件（此处：Label2）模拟系统转义符“ x”。

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


一个简单的UserForm代码示例

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

►截至2018年10月22日第2次编辑的注意事项

由于在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

►警告：未经Office 2010或更高版本中实际安装的64位系统测试的API声明。截至2018年10月22日的第二次Edit尝试更正几个LongPtr声明（仅用于指向→句柄或→内存位置的指针），并使用当前的Get / SetWindowLongPtr函数明确区分Win64和Win32; cf.还编辑了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）。

因此，经常会在版本'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可能也会引起关注