The possibility of calling InputBox with unicode support has already been discussed on this forum, but in fact, I can provide you with the correct source code of the InputBox function.
v. 2.5
v. 2.55 (MultiLine Input)
v. 2.5
Code:
Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 2024-02-01 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru //
'// Version 2.5 //
'////////////////////////////////////////////
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 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 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 SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpW" (ByVal hwnd As Long, ByVal lpHelpFile As Long, ByVal wCommand As Long, ByVal dwData As Long) As Long
Private Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpW" (ByVal hwndCaller As Long, ByVal pszFile As Long, ByVal uCommand As Long, ByVal dwData 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 WM_HELP = &H53
Private Const WM_DESTROY = &H2
Private Const SW_HIDE = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const EM_SETSEL = &HB1
Private Const SPI_GETWORKAREA = 48
Private Const HH_DISPLAY_TOPIC = &H0
Private Const HH_HELP_CONTEXT = &HF
Private Const HELP_CONTEXT = &H1
Private Const HELP_INDEX = &H3
Private Const HELP_QUIT = &H2
Private Type RECT
iLeft As Long
iTop As Long
iRight As Long
iBottom As Long
End Type
Dim sInputText As String
Dim sTitleText As String
Dim sDefaultText As String
Dim CenterOnWorkspace As Boolean ' Analog of DS_CENTER
Dim iXPos As Integer
Dim iYPos As Integer
Dim sHelpFile As String
Dim lContext As Long
Dim IsWinHelpRunning As Boolean
' Call InputBox from msvbvm60.dll with unicode support
Public Function InputBoxW(ByVal hParent As Long, ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String, Optional intXPos As Integer, Optional intYPos As Integer, Optional strHelpFile As String, Optional intContext As Long, Optional CenterOnMonitorWorkspace As Boolean) As String
Dim msvbvm60 As Long
msvbvm60 = LoadLibrary(StrPtr("msvbvm60.dll"))
If msvbvm60 <> 0 Then
sTitleText = strTitle
sDefaultText = strDefault
CenterOnWorkspace = CenterOnMonitorWorkspace
iXPos = intXPos
iYPos = intYPos
sHelpFile = strHelpFile
lContext = intContext
IsWinHelpRunning = False
DialogBoxParam msvbvm60, 4031, hParent, AddressOf DlgProc, StrPtr(strPrompt) ' The very cherished code that calls InputBox
End If
InputBoxW = sInputText
sInputText = vbNullString
sTitleText = vbNullString
sDefaultText = vbNullString
sHelpFile = vbNullString
End Function
' Dialog box message processing function
Private Function DlgProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim NotifyCode As Long
Dim ItemID As Long
Dim wndRect As RECT
Dim rcWork As RECT
Dim TextLen As Long
Dim lLeft As Long
Dim lTop As Long
Select Case uMsg
Case WM_INITDIALOG
If Len(sTitleText) = 0 Then sTitleText = App.Title
SetWindowText hwndDlg, StrPtr(sTitleText)
If Len(sHelpFile) = 0 Then
ShowWindow GetDlgItem(hwndDlg, ID_HELP), SW_HIDE
End If
SetDlgItemText hwndDlg, ID_STATIC, lParam
' Determining the size of the window
GetWindowRect hwndDlg, wndRect
' Determine the size of the working area of the screen
SystemParametersInfo SPI_GETWORKAREA, 0, rcWork, 0
If CenterOnWorkspace = False Then ' Standard alignment
If (iXPos Or iYPos) = 0 Then
' Absolutely perfect dialog box alignment code, exactly like the original InputBox function does
lLeft = rcWork.iLeft + (rcWork.iRight - rcWork.iLeft - (wndRect.iRight - wndRect.iLeft)) \ 2
lTop = rcWork.iTop + (rcWork.iBottom - rcWork.iTop - (wndRect.iBottom - wndRect.iTop)) \ 3
Else
lLeft = iXPos
lTop = iYPos
End If
Else ' Centering on the working area of the screen (analogous to the DS_CENTER style)
lLeft = ((rcWork.iRight - rcWork.iLeft) - (wndRect.iRight - wndRect.iLeft)) / 2
lTop = ((rcWork.iBottom - rcWork.iTop) - (wndRect.iBottom - wndRect.iTop)) / 2
End If
SetWindowPos hwndDlg, 0, lLeft, lTop, 0, 0, SWP_NOSIZE Or SWP_NOZORDER ' Alignment of the dialog box
If Len(sDefaultText) > 0 Then
SetDlgItemText hwndDlg, ID_EDIT, StrPtr(sDefaultText)
SendDlgItemMessage hwndDlg, ID_EDIT, EM_SETSEL, 0, -1
End If
DlgProc = 1
Exit Function
Case WM_COMMAND
NotifyCode = wParam \ 65536
ItemID = wParam And 65535
If ItemID = IDOK Then
TextLen = SendDlgItemMessage(hwndDlg, ID_EDIT, WM_GETTEXTLENGTH, 0, 0)
sInputText = Space$(TextLen)
GetDlgItemText hwndDlg, ID_EDIT, StrPtr(sInputText), TextLen + 1
EndDialog hwndDlg, 0
DlgProc = 1
Exit Function
End If
If ItemID = IDCANCEL Then
EndDialog hwndDlg, 0
DlgProc = 1
Exit Function
End If
If ItemID = ID_HELP Then
RunHelp hwndDlg
DlgProc = 1
Exit Function
End If
Case WM_HELP
RunHelp hwndDlg
DlgProc = 1
Exit Function
Case WM_DESTROY
If IsWinHelpRunning = True Then
WinHelp hwndDlg, 0, HELP_QUIT, 0 ' Close the HLP window
End If
DlgProc = 1
Exit Function
End Select
DlgProc = 0
End Function
Private Sub RunHelp(ByVal hwnd As Long)
If Len(sHelpFile) > 0 Then
If Right$(sHelpFile, 4) = ".hlp" Then
If lContext = 0 Then
WinHelp hwnd, StrPtr(sHelpFile), HELP_INDEX, 0
Else
WinHelp hwnd, StrPtr(sHelpFile), HELP_CONTEXT, lContext
End If
IsWinHelpRunning = True
Else ' CHM
If lContext = 0 Then
HtmlHelp hwnd, StrPtr(sHelpFile), HH_DISPLAY_TOPIC, 0
Else
HtmlHelp hwnd, StrPtr(sHelpFile), HH_HELP_CONTEXT, lContext
End If
End If
End If
End SubCode:
Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 2024-02-03 by HackerVlad //
'// e-mail: vladislavpeshkov@yandex.ru //
'// Version 2.55 (MultiLine Input) //
'////////////////////////////////////////////
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 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 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 SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpW" (ByVal hwnd As Long, ByVal lpHelpFile As Long, ByVal wCommand As Long, ByVal dwData As Long) As Long
Private Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpW" (ByVal hwndCaller As Long, ByVal pszFile As Long, ByVal uCommand As Long, ByVal dwData 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 GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam 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 WM_HELP = &H53
Private Const WM_DESTROY = &H2
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const WM_USER = &H400
Private Const EM_SETWORDWRAPMODE As Long = (WM_USER + 102)
Private Const ES_MULTILINE = &H4&
Private Const ES_WANTRETURN = &H1000&
Private Const WS_VSCROLL = &H200000
Private Const ES_UPPERCASE = &H8&
Private Const SWP_NOMOVE = &H2
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Const ES_AUTOVSCROLL = &H40&
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_EX_CLIENTEDGE As Long = &H200&
Private Const WS_CHILD As Long = &H40000000
Private Const ES_AUTOHSCROLL = &H80&
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WM_SETFONT = &H30
Private Const WM_GETFONT = &H31
Private Const WS_TABSTOP = &H10000
Private Const SW_HIDE = 0
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const EM_SETSEL = &HB1
Private Const SPI_GETWORKAREA = 48
Private Const HH_DISPLAY_TOPIC = &H0
Private Const HH_HELP_CONTEXT = &HF
Private Const HELP_CONTEXT = &H1
Private Const HELP_INDEX = &H3
Private Const HELP_QUIT = &H2
Private Type RECT
iLeft As Long
iTop As Long
iRight As Long
iBottom As Long
End Type
Dim sInputText As String
Dim sTitleText As String
Dim sDefaultText As String
Dim CenterOnWorkspace As Boolean ' Analog of DS_CENTER
Dim iXPos As Integer
Dim iYPos As Integer
Dim sHelpFile As String
Dim lContext As Long
Dim IsWinHelpRunning As Boolean
' Call InputBox from msvbvm60.dll with unicode support
Public Function InputBoxW(ByVal hParent As Long, ByVal strPrompt As String, Optional ByVal strTitle As String, Optional ByVal strDefault As String, Optional intXPos As Integer, Optional intYPos As Integer, Optional strHelpFile As String, Optional intContext As Long, Optional CenterOnMonitorWorkspace As Boolean) As String
Dim msvbvm60 As Long
msvbvm60 = LoadLibrary(StrPtr("msvbvm60.dll"))
If msvbvm60 <> 0 Then
sTitleText = strTitle
sDefaultText = strDefault
CenterOnWorkspace = CenterOnMonitorWorkspace
iXPos = intXPos
iYPos = intYPos
sHelpFile = strHelpFile
lContext = intContext
IsWinHelpRunning = False
DialogBoxParam msvbvm60, 4031, hParent, AddressOf DlgProc, StrPtr(strPrompt) ' The very cherished code that calls InputBox
End If
InputBoxW = sInputText
sInputText = vbNullString
sTitleText = vbNullString
sDefaultText = vbNullString
sHelpFile = vbNullString
End Function
' Dialog box message processing function
Private Function DlgProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim NotifyCode As Long
Dim ItemID As Long
Dim wndRect As RECT
Dim rcWork As RECT
Dim rcEdit As RECT
Dim TextLen As Long
Dim lLeft As Long
Dim lTop As Long
Dim hEdit As Long
Dim hFont As Long
Select Case uMsg
Case WM_INITDIALOG
If Len(sTitleText) = 0 Then sTitleText = App.Title
SetWindowText hwndDlg, StrPtr(sTitleText)
If Len(sHelpFile) = 0 Then
ShowWindow GetDlgItem(hwndDlg, ID_HELP), SW_HIDE
End If
SetDlgItemText hwndDlg, ID_STATIC, lParam
' Determining the size of the window
GetWindowRect hwndDlg, wndRect
' Determine the size of the working area of the screen
SystemParametersInfo SPI_GETWORKAREA, 0, rcWork, 0
If CenterOnWorkspace = False Then ' Standard alignment
If (iXPos Or iYPos) = 0 Then
' Absolutely perfect dialog box alignment code, exactly like the original InputBox function does
lLeft = rcWork.iLeft + (rcWork.iRight - rcWork.iLeft - (wndRect.iRight - wndRect.iLeft)) \ 2
lTop = rcWork.iTop + (rcWork.iBottom - rcWork.iTop - (wndRect.iBottom - wndRect.iTop)) \ 3
Else
lLeft = iXPos
lTop = iYPos
End If
Else ' Centering on the working area of the screen (analogous to the DS_CENTER style)
lLeft = ((rcWork.iRight - rcWork.iLeft) - (wndRect.iRight - wndRect.iLeft)) / 2
lTop = ((rcWork.iBottom - rcWork.iTop) - (wndRect.iBottom - wndRect.iTop)) / 2
End If
SetWindowPos hwndDlg, 0, lLeft, lTop, 0, 0, SWP_NOSIZE Or SWP_NOZORDER ' Alignment of the dialog box
' Gets a handle to ID_EDIT
hEdit = GetDlgItem(hwndDlg, ID_EDIT)
' Set ID_EDIT to be displayed in multiple lines with a vertical scroll bar
'SetWindowLong hEdit, GWL_STYLE, GetWindowLong(hEdit, GWL_STYLE) - ES_AUTOHSCROLL - WS_MAXIMIZEBOX
'SetWindowLong hEdit, GWL_STYLE, GetWindowLong(hEdit, GWL_STYLE) Or ES_MULTILINE Or WS_VSCROLL Or ES_AUTOVSCROLL Or ES_WANTRETURN
'SetWindowLong hEdit, GWL_STYLE, 1342181444
'SetWindowLong hEdit, GWL_EXSTYLE, 512
'SetWindowPos hEdit, 0, 0, 0, 350, 50, SWP_NOZORDER Or SWP_NOMOVE Or SWP_FRAMECHANGED
' Sets the WordWrap property to True
'SendMessage hEdit, EM_SETWORDWRAPMODE, 1, 0
' SetWindowLong does not help, so we will recreate the window
' using the DestroyWindow and CreateWindowEx functions
' Note:
' If you remove ES_WANTRETURN, the line break will be only through the Ctrl+Enter keys
GetWindowRect hEdit, rcEdit
hFont = SendMessage(hEdit, WM_GETFONT, 0, 0)
DestroyWindow hEdit
hEdit = CreateWindowEx(WS_EX_CLIENTEDGE, StrPtr("Edit"), ByVal 0&, WS_CHILD Or WS_VISIBLE Or ES_MULTILINE Or WS_TABSTOP Or _
ES_AUTOVSCROLL Or ES_WANTRETURN, 10, 75, rcEdit.iRight - rcEdit.iLeft, (rcEdit.iBottom - rcEdit.iTop) * 2, hwndDlg, ID_EDIT, 0&, ByVal 0&)
SendMessage hEdit, WM_SETFONT, hFont, ByVal 0&
If Len(sDefaultText) > 0 Then
SetDlgItemText hwndDlg, ID_EDIT, StrPtr(sDefaultText)
SendDlgItemMessage hwndDlg, ID_EDIT, EM_SETSEL, 0, -1
End If
DlgProc = 1
Exit Function
Case WM_COMMAND
NotifyCode = wParam \ 65536
ItemID = wParam And 65535
If ItemID = IDOK Then
TextLen = SendDlgItemMessage(hwndDlg, ID_EDIT, WM_GETTEXTLENGTH, 0, 0)
sInputText = Space$(TextLen)
GetDlgItemText hwndDlg, ID_EDIT, StrPtr(sInputText), TextLen + 1
EndDialog hwndDlg, 0
DlgProc = 1
Exit Function
End If
If ItemID = IDCANCEL Then
EndDialog hwndDlg, 0
DlgProc = 1
Exit Function
End If
If ItemID = ID_HELP Then
RunHelp hwndDlg
DlgProc = 1
Exit Function
End If
Case WM_HELP
RunHelp hwndDlg
DlgProc = 1
Exit Function
Case WM_DESTROY
If IsWinHelpRunning = True Then
WinHelp hwndDlg, 0, HELP_QUIT, 0 ' Close the HLP window
End If
DlgProc = 1
Exit Function
End Select
DlgProc = 0
End Function
Private Sub RunHelp(ByVal hwnd As Long)
If Len(sHelpFile) > 0 Then
If Right$(sHelpFile, 4) = ".hlp" Then
If lContext = 0 Then
WinHelp hwnd, StrPtr(sHelpFile), HELP_INDEX, 0
Else
WinHelp hwnd, StrPtr(sHelpFile), HELP_CONTEXT, lContext
End If
IsWinHelpRunning = True
Else ' CHM
If lContext = 0 Then
HtmlHelp hwnd, StrPtr(sHelpFile), HH_DISPLAY_TOPIC, 0
Else
HtmlHelp hwnd, StrPtr(sHelpFile), HH_HELP_CONTEXT, lContext
End If
End If
End If
End Sub