Как создать на VB6 уникодный InputBox? Чтобы при вводе в InputBox можно было получать китайские иероглифы и так далее

Option Explicit
'////////////////////////////////////////////
'// Модуль создания уникодного InputBox'а  //
'// Copyright (c) 15.11.2023 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru     //
'// Версия 1.0                             //
'////////////////////////////////////////////
 
Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Const EVENT_OBJECT_SHOW As Long = &H8002&
Private Const WM_COMMAND = &H111
Private Const IDOK = 1
Private Const WM_GETTEXT As Long = &HD
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_SETTEXT = &HC
Private Const EM_SETSEL = &HB1
 
Dim hEvent As Long
Dim HandleDialogWindow As Long
Dim HandleEdit As Long
Dim Subclassed As Long
Dim InputText As String
Dim TitleCaption As String
Dim DialogPrompt As String
Dim TextDefault As String
 
Public Function InputBoxW(ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String) As String
    InputText = vbNullString
    HandleDialogWindow = 0
    Subclassed = 0
    HandleEdit = 0
    hEvent = 0
    
    ' Устанавливаем хук на создание окон в системе
    hEvent = SetWinEventHook(EVENT_OBJECT_SHOW, EVENT_OBJECT_SHOW, 0, AddressOf WinEventProc, 0, App.ThreadID, 0)
    
    DialogPrompt = strPrompt
    TitleCaption = strTitle
    TextDefault = strDefault
    
    InputBox strPrompt, "" ' Вызвать классический InputBox
    
    RemoveWindowSubclass Subclassed, AddressOf WndProc, 0 ' Снять субклассирование
    If hEvent > 0 Then UnhookWinEvent hEvent
    
    InputBoxW = InputText
End Function
 
' Функция вызывается при создании окна
Private Sub WinEventProc(ByVal hWinEventHook As Long, ByVal dwEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
    Dim cls As String
    Dim sLn As Long
    Dim hwndStatic As Long
    
    cls = Space(256)
    
    ' Получаем имя класса окна
    sLn = GetClassName(hwnd, StrPtr(cls), Len(cls))
    
    If sLn Then
        cls = Left(cls, sLn)
        
        If StrComp(cls, "Edit", vbTextCompare) = 0 Then
            HandleEdit = hwnd ' Запомнить hwnd текстового поля
        End If
        
        If cls = "#32770" Then ' Если класс этого окна это диалоговое окно
            HandleDialogWindow = hwnd ' Запомнить hwnd диалогового окна
            hwndStatic = FindWindowEx(hwnd, ByVal 0&, "Static", vbNullString) ' Найти Static
            If TitleCaption = "" Then TitleCaption = App.Title
            
            ' Установить заголовок окна с поддержкой уникода (SendMessage не работает в этом случае)
            DefWindowProcW hwnd, WM_SETTEXT, 0, StrPtr(TitleCaption)
            
            ' Установить заголовок окна с поддержкой уникода (а вот здесь SendMessage уже работает почему-то)
            SendMessage hwndStatic, WM_SETTEXT, 0, StrPtr(DialogPrompt)
            
            If Len(TextDefault) > 0 Then
                SendMessage HandleEdit, WM_SETTEXT, 0, StrPtr(TextDefault)
                SendMessage HandleEdit, EM_SETSEL, 0, -1
            End If
            
            If HandleEdit > 0 And HandleDialogWindow > 0 Then
                ' Снять хук, если мы получили оба значения и HandleDialogWindow и HandleEdit
                If hEvent > 0 Then ' Только единожды
                    UnhookWinEvent hEvent
                    hEvent = 0
                End If
            End If
            
            If Subclassed = 0 Then
                Subclassed = SetWindowSubclass(HandleDialogWindow, AddressOf WndProc, 0&)
            End If
        End If
    End If
End Sub
 
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Dim bProcessed As Boolean
    Dim TextLen As Long
    
    Select Case uMsg
        Case WM_COMMAND
            If wParam = IDOK Then ' Событие которое обрабатывается при нажатии ОК
                InputText = Space$(256)
                TextLen = SendMessage(HandleEdit, WM_GETTEXTLENGTH, 0, 0)
                SendMessage HandleEdit, WM_GETTEXT, TextLen + 1, StrPtr(InputText)
                InputText = Left$(InputText, TextLen)
            End If
    End Select
    
    If Not bProcessed Then
        WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
    End If
End Function

Option Explicit
Private Declare Function DefWindowProcW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_SETTEXT = &HC
 
Private Sub Command1_Click()
    Dim str As String
    
    str = InputBoxW("Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H88E7) & "):", "Дружба народов " & ChrW(&H88E7), "Это китайский символ - " & ChrW(&H88E7))
    
    If Len(str) > 0 Then
        DefWindowProcW Me.hwnd, WM_SETTEXT, 0, ByVal StrPtr(Chr(34) & str & Chr(34))
    Else
        Me.Caption = "Canceled."
    End If
End Sub
 
Private Sub Form_Initialize()
    InitCommonControlsXP
End Sub

Option Explicit
'////////////////////////////////////////////
'// Модуль создания уникодного InputBox'а  //
'// Copyright (c) 16.11.2023 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru     //
'// Версия 1.1                             //
'////////////////////////////////////////////
 
Private Declare Function SetWinEventHook Lib "user32" (ByVal eventMin As Long, ByVal eventMax As Long, ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function UnhookWinEvent Lib "user32" (ByVal hWinEventHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Const EVENT_OBJECT_CREATE As Long = &H8000&
Private Const WM_COMMAND = &H111
Private Const IDOK = 1
Private Const WM_GETTEXT As Long = &HD
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_SETTEXT = &HC
Private Const EM_SETSEL = &HB1
Private Const WM_SHOWWINDOW As Long = &H18
 
Dim hEvent As Long
Dim HandleDialogWindow As Long
Dim HandleStatic As Long
Dim HandleEdit As Long
Dim Subclassed As Long
Dim InputText As String
Dim TitleCaption As String
Dim DialogPrompt As String
Dim TextDefault As String
 
Public Function InputBoxW(ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String) As String
    InputText = vbNullString
    HandleDialogWindow = 0
    HandleStatic = 0
    Subclassed = 0
    HandleEdit = 0
    hEvent = 0
    
    DialogPrompt = strPrompt
    TitleCaption = strTitle
    TextDefault = strDefault
    
    hEvent = SetWinEventHook(EVENT_OBJECT_CREATE, EVENT_OBJECT_CREATE, 0, AddressOf WinEventProc, 0, App.ThreadID, 0) ' Устанавливаем хук на создание окон в системе
    InputBox strPrompt, vbNullString ' Вызвать классический InputBox
    
    RemoveWindowSubclass Subclassed, AddressOf WndProc, 0 ' Снять субклассирование
    If hEvent > 0 Then UnhookWinEvent hEvent
    
    InputBoxW = InputText
End Function
 
' Функция вызывается при создании окна
Private Sub WinEventProc(ByVal hWinEventHook As Long, ByVal dwEvent As Long, ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, ByVal dwEventThread As Long, ByVal dwmsEventTime As Long)
    Dim cls As String
    Dim sLn As Long
    
    cls = Space(256)
    
    ' Получаем имя класса окна
    sLn = GetClassName(hwnd, StrPtr(cls), Len(cls))
    
    If sLn Then
        cls = Left(cls, sLn)
        
        If HandleDialogWindow = 0 Then
            If cls = "#32770" Then ' Если класс это диалоговое окно
                HandleDialogWindow = hwnd ' Запомнить hwnd диалогового окна
                
                If Subclassed = 0 Then
                    Subclassed = SetWindowSubclass(HandleDialogWindow, AddressOf WndProc, 0&)
                End If
            End If
        End If
        
        If HandleStatic = 0 Then
            If StrComp(cls, "Static", vbTextCompare) = 0 Then
                HandleStatic = hwnd
            End If
        End If
        
        If HandleEdit = 0 Then
            If StrComp(cls, "Edit", vbTextCompare) = 0 Then
                HandleEdit = hwnd ' Запомнить hwnd текстового поля
            End If
        End If
        
        If HandleDialogWindow > 0 And HandleStatic > 0 And HandleEdit > 0 Then
            If hEvent > 0 Then ' Только единожды
                UnhookWinEvent hEvent ' Снять хук
                hEvent = 0
            End If
        End If
    End If
End Sub
 
Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Dim bProcessed As Boolean
    Dim TextLen As Long
    
    Select Case uMsg
        Case WM_SHOWWINDOW
            If Len(TitleCaption) = 0 Then TitleCaption = App.Title
            SetWindowText HandleDialogWindow, StrPtr(TitleCaption)
            
            SendMessage HandleStatic, WM_SETTEXT, 0, StrPtr(DialogPrompt)
            
            If Len(TextDefault) > 0 Then
                SendMessage HandleEdit, WM_SETTEXT, 0, StrPtr(TextDefault) ' Установить текст по умолчанию в текстовом поле
                SendMessage HandleEdit, EM_SETSEL, 0, -1 ' Выделить всё в текстовом поле
            End If
        
        Case WM_COMMAND
            If wParam = IDOK Then ' Событие которое обрабатывается при нажатии ОК
                InputText = Space$(256)
                TextLen = SendMessage(HandleEdit, WM_GETTEXTLENGTH, 0, 0)
                SendMessage HandleEdit, WM_GETTEXT, TextLen + 1, StrPtr(InputText)
                InputText = Left$(InputText, TextLen)
            End If
    End Select
    
    If Not bProcessed Then
        WndProc = DefSubclassProc(hwnd, uMsg, wParam, lParam)
    End If
End Function

With TaskDialog1
    .Init
    .MainInstruction = "Введите имя новой папки:"
    .Content = "E:\Коллекция классов и модулей\2023\Диалог выбора папки 2.5\"
    .Flags = TDF_INPUT_BOX
    .CommonButtons = TDCBF_OK_BUTTON Or TDCBF_CANCEL_BUTTON
    .IconMain = TDN_TIMER
    .Title = "Создание папки"
    .ParenthWnd = Me.hWnd
    .ShowDialog
    
    
    Label5.Caption = .ResultInput
    If .ResultMain = TD_OK Then
        Label1.Caption = "Yes Yes Yes!"
    Else
        Label1.Caption = "Cancelled."
    End If
End With

Option Explicit
 
'-----------------------------------------------------------------------
' Win32 API Declarations
'-----------------------------------------------------------------------
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
 
Private Type DLGTEMPLATE
    style As Long
    dwExtendedStyle As Long
    cdit As Integer
    x As Integer
    y As Integer
    cx As Integer
    cy As Integer
End Type
 
Private Type DLGITEMTEMPLATE
    style As Long
    dwExtendedStyle As Long
    x As Integer
    y As Integer
    cx As Integer
    cy As Integer
    id As Integer
End Type
 
Private Type tagINITCOMMONCONTROLSEX
    dwSize As Long
    dwICC As Long
End Type
 
' Window Messages
Private Const WM_INITDIALOG = &H110
Private Const WM_COMMAND = &H111
Private Const WM_CLOSE = &H10
Private Const WM_USER = &H400
 
' Window Styles
Private Const WS_POPUP = &H80000000
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const WS_BORDER = &H800000
 
' Dialog Styles
Private Const DS_CENTER As Long = &H800&
Private Const DS_SETFONT As Long = &H40
Private Const DS_MODALFRAME = &H80
 
' Dialog Box Command IDs
Private Const IDOK = 1
Private Const IDCANCEL = 2
 
' Button Styles
Private Const BS_DEFPUSHBUTTON = &H1&
 
' Init Common Controls Flags
Private Const ICC_PROGRESS_CLASS = &H20
 
' Progress Bar Window Class
Private Const PROGRESS_CLASS As String = "msctls_progress32"
 
' Progress Bar Messages
Private Const PBM_SETPOS = WM_USER + 2
Private Const PBM_DELTAPOS = WM_USER + 3
Private Const PBM_SETSTEP = WM_USER + 4
Private Const PBM_STEPIT = WM_USER + 5
Private Const PBM_SETRANGE32 = WM_USER + 6
Private Const PBM_SETMARQUEE = WM_USER + 10
Private Const PBM_SETSTATE = WM_USER + 16
 
' Progress Bar Styles
Private Const PBS_MARQUEE = &H8
Private Const PBS_SMOOTH = &H1
Private Const PBS_SMOOTHREVERSE = &H10
Private Const PBS_VERTICAL = &H4
 
' Progress Bar States
Private Const PBST_NORMAL = 1
Private Const PBST_ERROR = 2
Private Const PBST_PAUSED = 3
 
' System Functions
Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" ( _
    Destination As Any, Source As Any, ByVal length As Long)
 
' Window Functions
Private Declare Function GetActiveWindow Lib "user32" _
    () As Long
 
Private Declare Function SetWindowText Lib "user32" _
    Alias "SetWindowTextA" ( _
    ByVal hWnd As Long, ByVal lpString As String) As Long
 
' Dialog Functions
Private Declare Function DialogBoxIndirectParam Lib "user32" _
    Alias "DialogBoxIndirectParamA" ( _
    ByVal hInstance As Long, ByVal lpTemplate As Long, _
    ByVal hWndParent As Long, ByVal lpDialogFunc As Long, _
    ByVal dwInitParam As Long) As Long
 
Private Declare Function SetDlgItemText Lib "user32" _
    Alias "SetDlgItemTextA" ( _
    ByVal hDlg As Long, ByVal nIDDlgItem As Long, _
    ByVal lpString As String) As Long
    
Private Declare Function SendDlgItemMessage Lib "user32" _
    Alias "SendDlgItemMessageA" ( _
    ByVal hDlg As Long, ByVal nIDDlgItem As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
 
Private Declare Function EndDialog Lib "user32" _
    (ByVal hDlg As Long, ByVal nResult As Long) As Long
    
' Common Controls Functions
Private Declare Function InitCommonControlsEx Lib "COMCTL32" _
    (ByRef picce As tagINITCOMMONCONTROLSEX) As Long
 
'-----------------------------------------------------------------------
' Progress Bar Functions
'-----------------------------------------------------------------------
 
' This type is necessary to ensure the dialog template, item templates,
' and their associated variable-length arrays are contiguous in memory.
' The DLGITEMTEMPLATE structures must be aligned on DWORD boundaries.
' The variable-length arrays must be aligned on WORD boundaries.
'
' Fixed-length byte arrays are used for the DLGITEMTEMPLATE class
' entries because VBA dynamic arrays would store a pointer in the UDT
' rather than the actual data. Titles are left blank in the template for
' convenience, to avoid alignment issues and conversion from BSTR to
' LPSTR. These can be set after the dialog is initialized.
 
Private Type DLG                     ' Length Padding Offset
    style As Long                    '      4       0      4
    extendedStyle As Long            '      4       0      8
    cdit As Integer                  '      2       0     10
    x As Integer                     '      2       0     12
    y As Integer                     '      2       0     14
    cx As Integer                    '      2       0     16
    cy As Integer                    '      2       0     18
    menu As Integer                  '      2       0     20
    class As Integer                 '      2       0     22
    title As Integer                 '      2       0     24
    
    progressStyle As Long            '      4       0     28
    progressExtendedStyle As Long    '      4       0     32
    progressX As Integer             '      2       0     34
    progressY As Integer             '      2       0     36
    progressCX As Integer            '      2       0     38
    progressCY As Integer            '      2       0     40
    progressID As Integer            '      2       2     44
    progressClass(34) As Byte        '     34       4     80
    progressTitle As Integer         '      2       0     82
    progressCreationData As Integer  '      2       0     84
    
    buttonStyle As Long              '      4       0     88
    buttonExtendedStyle As Long      '      4       0     92
    buttonX As Integer               '      2       0     94
    buttonY As Integer               '      2       0     96
    buttonCX As Integer              '      2       0     98
    buttonCY As Integer              '      2       0    100
    buttonID As Integer              '      2       2    104
    buttonClass(4) As Byte           '      4       0    108
    buttonTitle As Integer           '      2       0    110
    buttonCreationData As Integer    '      2       0    112
End Type
 
 
Public Function CreateProgressDialog()
    ' Build the dialog template.
    Dim template As DLG
    
    ' Check for the correct length. Only tested in 32-bit Office.
    Debug.Assert LenB(template) = 112
    
    template.style = DS_MODALFRAME Or WS_POPUP Or WS_BORDER Or _
                     WS_SYSMENU Or WS_CAPTION Or DS_CENTER
    template.extendedStyle = 0
    template.cdit = 2
    template.x = 200
    template.y = 200
    template.cx = 200
    template.cy = 49
    template.menu = 0
    template.class = 0
    template.title = 0
    
    ' Build the progress bar template.
    template.progressStyle = WS_CHILD Or WS_VISIBLE Or PBS_SMOOTH
    template.progressExtendedStyle = 0
    template.progressX = 7
    template.progressY = 7
    template.progressCX = 200 - 14
    template.progressCY = 14
    template.progressID = 10
    template.progressTitle = 0
    template.progressCreationData = 0
    
    Dim progressClass() As Byte
    progressClass = PROGRESS_CLASS
    CopyMemory template.progressClass(0), progressClass(0), 33
    
    ' Build the button template.
    template.buttonStyle = WS_CHILD Or WS_VISIBLE Or BS_DEFPUSHBUTTON
    template.buttonExtendedStyle = 0
    template.buttonX = 200 - 50 - 7
    template.buttonY = 28
    template.buttonCX = 50
    template.buttonCY = 14
    template.buttonID = IDCANCEL
    template.buttonClass(0) = &HFF
    template.buttonClass(1) = &HFF
    template.buttonClass(2) = &H80
    template.buttonCreationData = 0
    
    ' Use the active window as parent.
    Dim hWndParent As Long
    hWndParent = GetActiveWindow()
    
    ' Register the progress bar control class.
    Dim InitCtrlEx As tagINITCOMMONCONTROLSEX
    InitCtrlEx.dwSize = LenB(InitCtrlEx)
    InitCtrlEx.dwICC = ICC_PROGRESS_CLASS
    InitCommonControlsEx InitCtrlEx
    
    ' Create the dialog box.
    DialogBoxIndirectParam hInstance:=0, _
                           lpTemplate:=VarPtr(template), _
                           hWndParent:=hWndParent, _
                           lpDialogFunc:=AddressOf DlgProc, _
                           dwInitParam:=0
End Function
 
 
Private Function LOWORD(dw As Long) As Integer
    If dw And &H8000& Then
        LOWORD = dw Or &HFFFF0000
    Else
        LOWORD = dw And &HFFFF&
    End If
End Function
 
Private Function DlgProc(ByVal hWnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
    
    Select Case wMsg
    Case WM_INITDIALOG
        SetDlgItemText hWnd, IDCANCEL, "Cancel"
        SetWindowText hWnd, "Progress"
        
        ' Do a long running operation here, and check for cancel.
        SendDlgItemMessage hWnd, 10, PBM_STEPIT, 0, 0
        SendDlgItemMessage hWnd, 10, PBM_SETPOS, 50, 0
        
        ' Examples of different status states.
        'SendDlgItemMessage hWnd, 10, PBM_SETSTATE, PBST_ERROR, 0
        'SendDlgItemMessage hWnd, 10, PBM_SETSTATE, PBST_PAUSED, 0
        
        DlgProc = 1
        Exit Function
        
    Case WM_COMMAND
        Select Case LOWORD(wParam)
        Case IDOK
        Case IDCANCEL
            EndDialog hWnd, 0
            DlgProc = 1
        End Select
        Exit Function
        
    Case WM_CLOSE
        EndDialog hWnd, 0
        DlgProc = 1
        Exit Function
        
    End Select
    DlgProc = 0
End Function

Public Sub GetScreenSizes(screenWidth As Long, screenHeight As Long)
    Dim hDC As LongPtr
    ' Определяем размеры экрана
    hDC = GetDC(0)
    screenWidth = GetDeviceCaps(hDC, HORZRES) 'Screen.Width / Screen.TwipsPerPixelX
    screenHeight = GetDeviceCaps(hDC, VERTRES) 'Screen.Height / Screen.TwipsPerPixelY
    ReleaseDC 0, hDC
End Sub