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

Question

Please Look at the code below and test it:

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

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 TM, Mathieu Guindon and ... does not say: " Your question is amiss. Please read the links ...." )

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

Answer 1

Simulate Right To Left display as in MsgBox

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. Identify the Userform's handle to get access to further API methods
2. Remove the Userform's title bar
3. Replace it eg 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 - Application Programming Interface

A simple UserForm code example

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.

► Note to 2nd edit as of 10/22 2018

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 (eg #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. Separate code module for API functions

a) Declaration head with constants and special API declarations

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

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

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) Following Procedures (after section 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

► 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).

See also Compatibility between 32bit and 64bit Versions of Office 2010 and Office 2010 Help Files: Win32API PtrSafe with 64bit Support

Additional note

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.

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 

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

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

Recommended further reading

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