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

Option Explicit
 
Public Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, ByVal lpTemplate As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
Public Declare Function EndDialog Lib "user32" (ByVal hDlg As Long, ByVal nResult As Long) As Long
 
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Public Declare Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
 
Public Const MB_OK = &H0&
Public Const MB_ICONINFORMATION = &H40&
 
Public Const CB_ADDSTRING = &H143
Public Const WM_INITDIALOG = &H110
Public Const WM_COMMAND = &H111
 
Public Const IDOK = 1
Public Const IDCANCEL = 2
Public Const BN_CLICKED = 0
 
'Функция обработки сообщений диалогового окна
Public Function DialogBoxProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If uMsg = WM_COMMAND Then
        
        If wParam = IDOK Or wParam = IDCANCEL Then
            EndDialog hwndDlg, 0
            DialogBoxProc = 1
            Exit Function
        End If
       
    End If
    
    If uMsg = WM_INITDIALOG Then
        
    End If
    
    DialogBoxProc = 0
End Function
 
Public Function ShowDialog(hParent As Long) As Boolean
    Dim hmsvbvm60 As Long
    
    hmsvbvm60 = LoadLibrary("msvbvm60.dll")
    
    If hmsvbvm60 <> 0 Then
        DialogBoxParam hmsvbvm60, 4031, hParent, AddressOf DialogBoxProc, 0 ' Тот самый заветный код, который вызывает InputBox
        
        FreeLibrary hmsvbvm60
    End If
End Function

Option Explicit
 
Private Sub cmdShowDialog_Click()
    ShowDialog hwnd
End Sub
 
Private Sub Command1_Click()
    Me.Caption = InputBox("123")
End Sub

DialogBoxParam msvbvm60, 4031, hParent, AddressOf DlgProc, StrPtr(strPrompt)

Option Explicit
'/////////////////////////////////////////////
'// Модуль для вызова юникодного InputBox'а //
'// Copyright (c) 19.11.2023 by HackerVlad  //
'// e-mail: vladislavpeshkov@yandex.ru      //
'// Версия 2.0                              //
'/////////////////////////////////////////////
 
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamW" (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 LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function EndDialog Lib "user32" (ByVal hDlg As Long, ByVal nResult As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageW" (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 SetDlgItemText Lib "user32" Alias "SetDlgItemTextW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As Long) As Long
Private Declare Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As Long, ByVal nMaxCount As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow 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 MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpmi As MONITORINFO) As Long
Private Declare Function MonitorFromWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal dwFlags As Long) As Long
 
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const ID_EDIT = 4900
Private Const ID_STATIC = 4901
Private Const ID_HELP = 4902
Private Const WM_COMMAND = &H111
Private Const WM_INITDIALOG = &H110
Private Const SW_HIDE = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const MONITOR_DEFAULTTONEAREST = &H2
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const EM_SETSEL = &HB1
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Public Type MONITORINFO
    cbSize As Long
    rcMonitor As RECT
    rcWork As RECT
    dwFlags As Long
End Type
 
Dim InputText As String
Dim TitleText As String
Dim DefaultText As String
Dim CenterOnWorkspace As Boolean ' Аналог DS_CENTER
 
' Вызвать InputBox из msvbvm60.dll с поддеркой юникода
Public Function InputBoxW(ByVal hParent As Long, ByVal strPrompt As String, Optional ByVal strTitle As String, Optional CenterOnMonitorWorkspace As Boolean, Optional ByVal strDefault As String) As String
    Dim msvbvm60 As Long
    
    msvbvm60 = LoadLibrary(StrPtr("msvbvm60.dll"))
    
    If msvbvm60 <> 0 Then
        TitleText = strTitle
        DefaultText = strDefault
        CenterOnWorkspace = CenterOnMonitorWorkspace
        DialogBoxParam msvbvm60, 4031, hParent, AddressOf DlgProc, StrPtr(strPrompt) ' Тот самый заветный код, который вызывает InputBox
    End If
    
    InputBoxW = InputText
    InputText = vbNullString
    TitleText = vbNullString
    DefaultText = vbNullString
End Function
 
' Функция обработки сообщений диалогового окна
Private Function DlgProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim NotidyCode As Long
    Dim ItemID As Long
    Dim rct As RECT
    Dim hMonitor As Long
    Dim MI As MONITORINFO
    Dim TextLen As Long
    
    Select Case uMsg
        Case WM_INITDIALOG
            If Len(TitleText) = 0 Then TitleText = App.Title
            SetWindowText hwndDlg, StrPtr(TitleText)
            
            ShowWindow GetDlgItem(hwndDlg, ID_HELP), SW_HIDE
            SetDlgItemText hwndDlg, ID_STATIC, lParam
            
            ' Определяем размеры окна
            GetWindowRect hwndDlg, rct
            
            If CenterOnWorkspace = False Then ' Стандартная центровка
                SetWindowPos hwndDlg, 0, ((Screen.Width / Screen.TwipsPerPixelX) - (rct.Right - rct.Left)) / 2, (((Screen.Height / Screen.TwipsPerPixelY) - (rct.Bottom - rct.Top)) / 2) - (rct.Bottom - rct.Top), 0, 0, SWP_NOSIZE Or SWP_NOZORDER
            Else ' Центровка по рабочей области экрана (аналог стиля DS_CENTER)
                hMonitor = MonitorFromWindow(hwndDlg, MONITOR_DEFAULTTONEAREST)
                MI.cbSize = LenB(MI)
                
                If GetMonitorInfo(hMonitor, MI) <> 0 Then
                    SetWindowPos hwndDlg, 0, ((MI.rcWork.Right - MI.rcWork.Left) - (rct.Right - rct.Left)) / 2, ((MI.rcWork.Bottom - MI.rcWork.Top) - (rct.Bottom - rct.Top)) / 2, 0, 0, SWP_NOSIZE Or SWP_NOZORDER
                End If
            End If
            
            If Len(DefaultText) > 0 Then
                SetDlgItemText hwndDlg, ID_EDIT, StrPtr(DefaultText)
                SendDlgItemMessage hwndDlg, ID_EDIT, EM_SETSEL, 0, -1
            End If
            
            DlgProc = 1
            Exit Function
        
        Case WM_COMMAND
            NotidyCode = wParam \ 65536
            ItemID = wParam And 65535
            
            If ItemID = IDOK Then
                TextLen = SendDlgItemMessage(hwndDlg, ID_EDIT, WM_GETTEXTLENGTH, 0, 0)
                InputText = Space$(TextLen)
                GetDlgItemText hwndDlg, ID_EDIT, StrPtr(InputText), TextLen + 1
                
                EndDialog hwndDlg, 0
                DlgProc = 1
                Exit Function
            End If
            
            If ItemID = IDCANCEL Then
                EndDialog hwndDlg, 0
                DlgProc = 1
                Exit Function
            End If
    End Select
    
    DlgProc = 0
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(0, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H4EBA) & "):", "Дружба народов " & ChrW(-29686), True, "Это китайский символ дружбы - " & ChrW(-29686))
    
    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 Command2_Click()
    Dim str As String
    
    str = InputBoxW(hwnd, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(-29686) & "):")
    
    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 Command3_Click()
    Dim str As String
    
    str = InputBoxW(hwnd, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H4EBA) & "):", "Дружба народов " & ChrW(-29686), True, "Это китайский символ дружбы - " & ChrW(-29686))
    
    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 Command4_Click()
    Dim str As String
    
    str = InputBoxW(hwnd, "Китайский язык приветствуется. " & vbNewLine & "Введите китайщину (например " & ChrW(&H4EBA) & "):", "Дружба народов " & ChrW(-29686), False, "Это китайский символ дружбы - " & ChrW(-29686))
    
    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

Public Function InputBoxW(Prompt, Title, Default) As String
Dim sc
Dim s
Set sc = CreateObject("msscriptcontrol.scriptcontrol")
sc.language = "vbscript"
s = sc.Eval("InputBox(""" & Prompt & """,""" & Title & """,""" & Default & """)")
If IsEmpty(s) Then s = vbNullString Else If Len(s) = 0 Then s = ""
InputBoxW = s
End Function

Public Function InputBoxW(Prompt, title, Optional Default = "") As String
Dim sc
Dim s
Dim p As String
Dim v As String
Set sc = CreateObject("MSScriptControl.ScriptControl")
sc.Language = "VBScript"
p = Prompt: GoSub jConcat
p = title: GoSub jConcat
p = Default: GoSub jConcat
If ObjPtr(Screen.ActiveForm) Then sc.SitehWnd = Screen.ActiveForm.hWnd
s = sc.Eval("InputBox(" & v & ")")
If IsEmpty(s) Then s = vbNullString Else If Len(s) = 0 Then s = ""
 
InputBoxW = s
Exit Function
 
jConcat:
If v <> "" Then v = v & ","
If InStr(1, p, """") Then p = Replace(p, """", """""")
If InStr(1, p, vbCrLf) Then p = Replace(p, vbCrLf, """ & vbNewLine & """)
If InStr(1, p, vbLf) Then p = Replace(p, vbLf, """ & vbNewLine & """)
v = v & ("""" & p & """")
Return
End Function