Excel中从右到左的用户表单-VBA [英] Right to left userforms in excel - VBA

问题描述

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

Please Look at the code below and test it:

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

此代码将消息窗口从右到左转换.当关闭按钮移至窗口左侧时.如何针对用户表单执行此操作?(希望 T.M.，Mathieu Guindon 和...不会说:"您的问题不对.请阅读链接...." )

This code convert the message window from right to left. As the close button moves to the left of the window. How do I do this for userforms? (Hope T.M., Mathieu Guindon and ... does not say: "Your question is amiss. Please read the links ....")

就像下面的图片(当然照片是photoshop！):

Like the picture below (Of course photo is photoshop!):

推荐答案

模拟从右到左的显示，如 MsgBox

Simulate Right To Left display as in MsgBox

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

It'll be necessary to use some API *) functions to get the wanted layout independant from language settings using right to left functionality by default.

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

4. 使用另一个控件(在这里: Label2 )模拟系统转义符"x".

1. Identify the Userform's handle to get access to further API methods
2. Remove the Userform's title bar
3. Replace it e.g. with a Label control displaying the caption and give it drag functionality to move the UserForm (here: Label1).

4. Use another control (here: Label2) to simulate the system escape "x".

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

一个简单的UserForm代码示例

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

All you need is to provide for 2 Label controls where Label1 replaces the title bar and receives the UserForm's caption and Label2 simulates the system Escape "x". Furthermore this example uses a Type declaration for easy disposal of the UserForm handle for several event procedures needing it for further API actions.

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

由于在Office 2010或更高版本中窗口句柄被声明为 LongPtr ，而在以前的版本中则声明为 Long ，因此必须通过条件编译常量来区分不同版本(例如， #If VBA7 Then ... #Else ... #End If ；请参阅第二部分.还使用 Win64 常量来实际标识 已安装64位Office系统-请注意，默认情况下，Office通常安装为32位).

As a window handle is declared as LongPtr in Office 2010 or higher and as Long in versions before, it was necessary to differentiate between the different versions by conditional compile constants (e.g. #If VBA7 Then ... #Else ... #End If; cf. section II. using also the Win64 constant to identify actually installed 64bit Office systems - note that frequently Office is installed as 32bit by default).

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

II.API函数的单独代码模块

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

有必要提供不同的应用程序版本，因为某些参数中的代码声明不同(例如PtrSafe).64位声明开始如下:私有声明PtrSafe ...

It's necessary to provide for different application versions as the code declarations differ in some arguments (e.g. PtrSafe). 64 bit declarations start as follows: Private Declare PtrSafe ...

还要通过 #If ， #Else 和 #End If 进行正确的声明，以允许依赖于版本的编译.

Take also care of the correct declarations via #If, #Else and #End If allowing version dependant compilation.

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

The prefix &H used in constants stands for hexadecimal values.

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日尝试更正几个 LongPtr 声明(仅适用于指向→句柄或→内存位置的指针)，并使用当前的Get/SetWindowLongPtr函数明确区分 Win64和 Win32 ；cf.还编辑了UserForm代码模块的声明标题中的 Type 声明).

► Caveat: API declarations not tested for actually installed 64 bit systems in Office 2010 or higher. The 2nd Edit as of 10/22 2018 tries to correct several LongPtr declarations (only for pointers to a → handle or → memory location) and using the current Get/SetWindowLongPtr function differentiating explicitly between Win64 and Win32; cf. also edited Type declaration in the UserForm code module's declaration head).

另请参见 Office 32位和64位版本之间的兼容性2010 和 Office 2010帮助文件:Win32API PtrSafe与64位支持

附加说明

UserForms是Windows，可以通过其窗口 handle 进行标识.用于此目的的API函数是 FindWindow ，它包含两个参数:1)一个字符串，给出需要查找的窗口的类的名称，2)一个字符串，给出需要查找的窗口的(em)标题(em).

UserForms are Windows and can be identified by their window handle. The API function used for this purpose is FindWindow disposing of two arguments: 1) A string giving the name of the class of the window it needs to find and 2) a string giving the caption of the window (UserForm) it needs to find.

因此，经常会在版本'97(用户窗体类名称为"ThunderXFrame")和更高版本("ThunderDFrame")之间进行区分:

Therefore frequently one distinguishes between version '97 (UserForm class name "ThunderXFrame") and later versions ("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 (和唯一标题！)可以使编码更加容易:

However using vbNullString (and unique captions!) instead makes coding much easier:

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

建议进一步阅读

UserForm代码模块实际上是类，应按原样使用.因此，我建议阅读M.Guindon的文章 UserForm1.Show .-可能也会引起一些兴趣，正确销毁无模式UserForm实例

UserForm code modules actually are classes and should be used as such. So I recommend reading M. Guindon's article UserForm1.Show. - Possibly of some interest, as well is Destroy a modeless UserForm instance properly

这篇关于Excel中从右到左的用户表单-VBA的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！