Question

Пожалуйста, посмотрите на код ниже и проверьте его:

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

Этот код преобразует окно сообщения справа налево.Как кнопка закрытия перемещается влево от окна.Как мне сделать это для пользовательских форм?(Надеюсь ТМ, Матье Гиндон и ... не говорит: " Ваш вопрос не подходит. Пожалуйста, прочитайте ссылки ...." )

Как иКартинка ниже (Конечно, фото - фотошоп!):

T.M. · Answer 1 · 14 октября 2018

Симуляция дисплея справа налево, как в MsgBox

Для получения нужного макета * 1008 потребуется использовать некоторые функции API *).* независимый от языковых настроек, использующих функциональность справа налево по умолчанию.

Определите дескриптор пользовательской формы , чтобы получить доступ к другим методам API
Удалите строку заголовка пользовательской формы
Замените ее, например, на элемент управления Label, отображающий заголовок и предоставляющий ему функцию перетаскивания для перемещения пользовательской формы (здесь: Label1).
Используйте другой элемент управления (здесь: Label2) для имитации выхода из системы "x".

*) API - интерфейс прикладного программирования

Простой пример кода пользовательской формы

Все, что вам нужно, это предоставить 2 элемента управления Label, где Label1 заменяет строку заголовка и получает заголовок пользовательской формы и Label2 Имитирует систему Escape "x".Кроме того, в этом примере используется объявление Type для простого удаления дескриптора UserForm для нескольких процедур обработки событий, которые необходимы для дальнейших действий API.

► Примечание ко 2-му редактированию с 10/ 22 2018

Поскольку дескриптор окна объявлен как LongPtr в Office 2010 или выше и как Long в версиях ранее, необходимо было различать разные версии по условным константам компиляции (например, #If VBA7 Then ... #Else ... #End If; см. раздел II. Использование также константы 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

II.Отдельный модуль кода для функций 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, не проверенные для на самом деле установленных 64-разрядных систем в Office 2010 или более поздней версии. 2-е Редактирование с 22.10 2018 пытается исправить несколько LongPtr объявления (только для указателей на → дескриптор или → область памяти) и использование текущей функции Get / SetWindowLongPtr с явным различием между Win64 и Win32;сртакже отредактировал объявление Type в заголовке объявления модуля кода UserForm).

См. Также Совместимость между 32-битной и 64-битной версиями Office 2010 и Файлы справки Office 2010: Win32API PtrSafe с поддержкой 64-битной версии

Дополнительнопримечание

Пользовательские формы являются Windows и могут быть идентифицированы по их окну handle .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

Рекомендуется дальнейшее чтение

Модули кода пользовательской формы на самом деле классы иследует использовать как таковой.Поэтому я рекомендую прочитать статью М. Guindon UserForm1.Show .- Возможно, также представляет интерес Правильно уничтожить немодальный экземпляр UserForm

Пользовательские формы справа налево в Excel - VBA

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Пользовательские формы справа налево в Excel - VBA

Пожалуйста, войдите или зарегистрируйтесь чтобы ответить на этот вопрос.

1 Ответ

Пожалуйста, войдите или зарегистрируйтесь что бы добавить комментарий.

Похожие темы