InputBox with full unicode support v. 2.5 and v. 2.55
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
Code:
Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 2024-02-01 by HackerVlad //
'// e-mail: [email protected] //
'// 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 Sub
v. 2.55 (MultiLine Input)
Code:
Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 2024-02-03 by HackerVlad //
'// e-mail: [email protected] //
'// 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
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Thanks for the code.
I have been wanting to do this in VBA for a long time so I wouldn't need to rely on the msvbvm60.dll. Unfortunately, I can't seem to find the resource template for the inputbox dialog anywhere in any of the VBE6/VBE7 related dlls .
Using the Resource Hacker, I have found many templates but the one for the InputBox is missing !
Re: InputBox with full unicode support v. 2.5 and v. 2.55
I used to think the same but unfortunately, "msvbvm60.dll" is a 32-bit DLL so it won't work with the 64-bit versions of Office that everyone are using nowadays...
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Doesn't the InputBox function support unicode by default in a 64-bit office??? Then there is a simpler code for you:
Code:
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
Re: InputBox with full unicode support v. 2.5 and v. 2.55
I am not so much interested in the actual unicode text as to how to find the corresponding resource template for the inputbox dialog as an example.
Seems that the developpers of vba are experts at making things difficult on purpose.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by AngelV
I am not so much interested in the actual unicode text as to how to find the corresponding resource template for the inputbox dialog as an example.
Seems that the developpers of vba are experts at making things difficult on purpose.
Why not use DialogBoxIndirectParamW and have the template resource persisted in the code directly? (In-memory; copy of vb6 template)
This would make it independent. Or do I miss something?
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by Krool
Why not use DialogBoxIndirectParamW and have the template resource persisted in the code directly? (In-memory; copy of vb6 template)
This would make it independent. Or do I miss something?
Krool, you're completely right. You can fully describe the dialog box in your own code and do not need to call the resources of any DLL. I'm calling a dialog box from resources just to simplify the code, in fact, you can describe exactly the same coordinates of the window yourself. However, you will have to tinker a little for this, of course.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Thanks Krool and HackerVlad,
Yes, I guess could achieve the same with DialogBoxIndirectParamW, CreateWindowExW or even simply by using a simple vba UserForm but I am intrigued as to why the InputBox dlg template is nowhere to be found except in the msvbvm60.dll yet, all office applications do use the InputBox function... so i wonder where on earth do excel, word, access etc retrieve the InputBox dlg!!!
Edit.
Btw, same happens with the standard vba MsgBox function. I can't find it anywhere in the VBE6/VBE7 related dlls either .
I am beginning to think that maybe those missing dlg templates are to be found in core windows dlls.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by AngelV
Thanks Krool and HackerVlad,
Yes, I guess could achieve the same with DialogBoxIndirectParamW, CreateWindowExW or even simply by using a simple vba UserForm but I am intrigued as to why the InputBox dlg template is nowhere to be found except in the msvbvm60.dll yet, all office applications do use the InputBox function... so i wonder where on earth do excel, word, access etc retrieve the InputBox dlg!!!
Edit.
Btw, same happens with the standard vba MsgBox function. I can't find it anywhere in the VBE6/VBE7 related dlls either .
I am beginning to think that maybe those missing dlg templates are to be found in core windows dlls.
I have no idea in which files the Office stores the dialog box and where to look for this DLL. And why know that? I think it extracts from the operating system, bypassing the Microsoft Office package files. MsgBox is called by the MessageBox API function, this is much easier.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by Krool
Why not use DialogBoxIndirectParamW and have the template resource persisted in the code directly? (In-memory; copy of vb6 template)
This would make it independent. Or do I miss something?
So if you saved a copy of the VB6 template would it work for the "DialogBoxIndirectParamW" function in x64 provided the 64-bit structures have different byte alignment? I don't have Office installed to test this...
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Please wrote for you, enjoy the focus of the input on the default text field.
Code:
Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 2024-02-12 by HackerVlad //
'// e-mail: [email protected] //
'// Version 2.6 (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 Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd 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
Dim hEdit As Long
' 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 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, 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
SetFocusAPI hEdit ' SetFocus NEW Text Field
DlgProc = 0
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
Re: InputBox with full unicode support v. 2.5 and v. 2.55
JFYI, here are the results from MZ-Tools linter
Code:
The declaration Declare 'GetWindowLong' is not used (it is used only inside commented block)
The declaration Declare 'SetWindowLong' is not used (it is used only inside commented block)
The constant 'GWL_STYLE' is not used (it is used only inside commented block)
The constant 'GWL_EXSTYLE' is not used (it is used only inside commented block)
The constant 'EM_SETWORDWRAPMODE' is not used (it is used only inside commented block)
The constant 'ES_WANTRETURN' is not used (it is used only inside commented block)
The constant 'WS_VSCROLL' is not used (it is used only inside commented block)
The constant 'ES_UPPERCASE' is not used
The constant 'SWP_NOMOVE' is not used (it is used only inside commented block)
The constant 'SWP_FRAMECHANGED' is not used (it is used only inside commented block)
The constant 'ES_AUTOHSCROLL' is not used (it is used only inside commented block)
The constant 'WS_MAXIMIZEBOX' is not used (it is used only inside commented block)
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by wqweto
JFYI, here are the results from MZ-Tools linter
Code:
The declaration Declare 'GetWindowLong' is not used (it is used only inside commented block)
The declaration Declare 'SetWindowLong' is not used (it is used only inside commented block)
The constant 'GWL_STYLE' is not used (it is used only inside commented block)
The constant 'GWL_EXSTYLE' is not used (it is used only inside commented block)
The constant 'EM_SETWORDWRAPMODE' is not used (it is used only inside commented block)
The constant 'ES_WANTRETURN' is not used (it is used only inside commented block)
The constant 'WS_VSCROLL' is not used (it is used only inside commented block)
The constant 'ES_UPPERCASE' is not used
The constant 'SWP_NOMOVE' is not used (it is used only inside commented block)
The constant 'SWP_FRAMECHANGED' is not used (it is used only inside commented block)
The constant 'ES_AUTOHSCROLL' is not used (it is used only inside commented block)
The constant 'WS_MAXIMIZEBOX' is not used (it is used only inside commented block)
cheers,
</wqW>
Well, delete what you don't need, I wrote it in a hurry at all only at the request of those who wish. You look at version 2.5 there is nothing superfluous.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by HackerVlad
Well, delete what you don't need, I wrote it in a hurry at all only at the request of those who wish. You look at version 2.5 there is nothing superfluous.
I noticed that you take great pride in your creative solution so thought you might want to comb out any redundancies/imperfections it might have.
Of course leaving it being good enough is always an option. I personally edit my old submissions here (years old) all the time when something more optimal is revealed on my path of knowledge.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Thanks for that comment. At DPI = 150%, I really haven't tested this code. As for the Russian language, it was most likely not encoded in unicode. This is just an example. Why do you need Russian words if you are from English-speaking countries or from Asia.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
You can specify the text box style and change its display position.
The background color of the text box can be displayed, and the background of the picture can be changed. Or add a photo frame to the white text box.
Word wrap adds a scroll bar.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by AAraya
Nice work HV but I have a problem which I thought you might want to know about.
Earlier versions worked well for me but version 2.55 has a display issue. (I'm at DPI = 150%, if that matters)
This is what I see when I run the EXE in your zip file:
And this is what I see when I run it in the IDE and click on the Main button in the demo:
The multiline text box is displaying over the buttons in both cases - though differently in each case for some reason.
I have checked on my screen now, it is displayed normally at both 125% and 150%. Unfortunately, I couldn't reproduce your problem to try to solve it. But I think you can do it yourself.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
You can do it if you want. If that's what you need. But I must warn you that changing the background color of the text field will be quite a difficult task for you. Since you will have to describe this behavior for two versions of the window at once, a stylized theme and a non-stylized one.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Thanks again for the initial source code. Inspired by this I adapted the code as shown below.
As suggested earlier it uses DialogBoxIndirectParamW instead of DialogBoxParamW which makes it independent.
Use of DS_CENTER style when the Center param is True.
New MaxLength param.
New Password param to set ES_PASSWORD when True.
Use of GetMonitorInfo to work properly on multi monitor setups.
X and Y param are treated as twips values.
Use of GetUserDefaultUILanguage to include german and some other localizations. The german dialog width and the buttons are slightly bigger. The dimensions are taken from the VBE7INTL.DLL.
Look for dialog 4031 and string table 1444 to get the dimensions and texts for your localization.
Also the code is x64 compatible. So it could be used in twinBASIC to replace the InputBox there as well.
Code:
Option Explicit
#If (VBA7 = 0) Then
Private Enum LongPtr
[_]
End Enum
#End If
#If Win64 Then
Private Const NULL_PTR As LongPtr = 0
Private Const PTR_SIZE As Long = 8
#Else
Private Const NULL_PTR As Long = 0
Private Const PTR_SIZE As Long = 4
#End If
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type MONITORINFO
cbSize As Long
RCMonitor As RECT
RCWork As RECT
dwFlags As Long
End Type
Private Type DLGINPUTBOX
dwStyle As Long
dwExStyle As Long
cItems As Integer
X As Integer
Y As Integer
CX As Integer
CY As Integer
Menu As Integer
ClassName As Integer
Title As Integer
FontSize As Integer
FontName(0 To (26 - 1)) As Byte
Item1_dwStyle As Long
Item1_dwExStyle As Long
Item1_X As Integer
Item1_Y As Integer
Item1_CX As Integer
Item1_CY As Integer
Item1_wID As Integer
Item1_ClassName As Integer
Item1_ClassAtom As Integer
Item1_Title As Integer
Item1_Data As Integer
Item1_wPadding As Integer
Item2_dwStyle As Long
Item2_dwExStyle As Long
Item2_X As Integer
Item2_Y As Integer
Item2_CX As Integer
Item2_CY As Integer
Item2_wID As Integer
Item2_ClassName As Integer
Item2_ClassAtom As Integer
Item2_Title As Integer
Item2_Data As Integer
Item2_wPadding As Integer
Item3_dwStyle As Long
Item3_dwExStyle As Long
Item3_X As Integer
Item3_Y As Integer
Item3_CX As Integer
Item3_CY As Integer
Item3_wID As Integer
Item3_ClassName As Integer
Item3_ClassAtom As Integer
Item3_Title As Integer
Item3_Data As Integer
Item3_wPadding As Integer
Item4_dwStyle As Long
Item4_dwExStyle As Long
Item4_X As Integer
Item4_Y As Integer
Item4_CX As Integer
Item4_CY As Integer
Item4_wID As Integer
Item4_ClassName As Integer
Item4_ClassAtom As Integer
Item4_Title As Integer
Item4_Data As Integer
Item4_wPadding As Integer
Item5_dwStyle As Long
Item5_dwExStyle As Long
Item5_X As Integer
Item5_Y As Integer
Item5_CX As Integer
Item5_CY As Integer
Item5_wID As Integer
Item5_ClassName As Integer
Item5_ClassAtom As Integer
Item5_Title As Integer
Item5_Data As Integer
Item5_wPadding As Integer
End Type
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Integer
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function DialogBoxIndirectParam Lib "user32" Alias "DialogBoxIndirectParamW" (ByVal hInstance As LongPtr, ByVal hDialogTemplate As LongPtr, ByVal hWndParent As LongPtr, ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As LongPtr
Private Declare PtrSafe Function EndDialog Lib "user32" (ByVal hDlg As LongPtr, ByVal nResult As LongPtr) As Long
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageW" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextW" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextW" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As LongPtr, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hWnd As LongPtr, ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function MonitorFromWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoW" (ByVal hMonitor As LongPtr, ByRef lpMI As MONITORINFO) As Long
Private Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxW" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal wType As Long) As Long
Private Declare PtrSafe Function WinHelp Lib "user32" Alias "WinHelpW" (ByVal hWnd As LongPtr, ByVal lpHelpFile As LongPtr, ByVal wCommand As Long, ByVal dwData As LongPtr) As Long
Private Declare PtrSafe Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpW" (ByVal hWndCaller As LongPtr, ByVal lpszFile As LongPtr, ByVal uCommand As Long, ByVal dwData As LongPtr) As LongPtr
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Integer
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function DialogBoxIndirectParam Lib "user32" Alias "DialogBoxIndirectParamW" (ByVal hInstance As Long, ByVal hDialogTemplate As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam 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, ByRef 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 GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function MonitorFromWindow Lib "user32" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoW" (ByVal hMonitor As Long, ByRef lpMI As MONITORINFO) As Long
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxW" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal wType 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 lpszFile As Long, ByVal uCommand As Long, ByVal dwData As Long) As Long
#End If
Private Const ID_OK As Long = 1
Private Const ID_CANCEL As Long = 2
Private Const ID_EDIT As Long = 4900
Private Const ID_STATIC As Long = 4901
Private Const ID_HELP As Long = 4902
Private Const DS_3DLOOK As Long = &H4
Private Const DS_SETFONT As Long = &H40
Private Const DS_MODALFRAME As Long = &H80
Private Const DS_CENTER As Long = &H800
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_TABSTOP As Long = &H10000
Private Const WS_GROUP As Long = &H20000
Private Const WS_SYSMENU As Long = &H80000
Private Const WS_BORDER As Long = &H800000
Private Const WS_POPUP As Long = &H80000000
Private Const SS_LEFT As Long = &H0
Private Const SS_NOPREFIX As Long = &H80
Private Const ES_LEFT As Long = &H0
Private Const ES_PASSWORD As Long = &H20
Private Const ES_AUTOHSCROLL As Long = &H80
Private Const BS_PUSHBUTTON As Long = &H0
Private Const BS_DEFPUSHBUTTON As Long = &H1
Private Const WM_COMMAND As Long = &H111
Private Const WM_INITDIALOG As Long = &H110
Private Const WM_HELP As Long = &H53
Private Const WM_DESTROY As Long = &H2
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const EM_SETSEL As Long = &HB1
Private Const EM_LIMITTEXT As Long = &HC5
Private Const EM_SETLIMITTEXT As Long = EM_LIMITTEXT
Private Const SW_HIDE As Long = 0
Private Const SWP_NOOWNERZORDER As Long = &H200
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const MONITOR_DEFAULTTOPRIMARY As Long = &H1
Private Const HH_DISPLAY_TOPIC As Long = &H0
Private Const HH_HELP_CONTEXT As Long = &HF
Private Const HELP_CONTEXT As Long = &H1
Private Const HELP_INDEX As Long = &H3
Private Const HELP_QUIT As Long = &H2
Private PropInput As String
Private PropTitle As String
Private PropDefault As String
Private PropXPos As Variant
Private PropYPos As Variant
Private PropHelpFile As String
Private PropContext As Long
Private PropCenter As Boolean
Private PropMaxLength As Long
Private PropPassword As Boolean
Private PropLangID As Integer
Private PropWinHelpRunning As Boolean
' (VB-Overwrite)
Public Function InputBox(ByVal Prompt As String, Optional ByVal Title As Variant, Optional ByVal Default As String, Optional ByVal XPos As Variant, Optional ByVal YPos As Variant, Optional ByVal HelpFile As String, Optional ByVal Context As Long, Optional ByVal Center As Boolean, Optional ByVal MaxLength As Long, Optional ByVal Password As Boolean) As String
If Not IsMissing(Title) Then
PropTitle = Title
Else
PropTitle = App.Title
End If
If MaxLength > 0 Then
PropDefault = Left$(Default, MaxLength)
Else
PropDefault = Default
End If
If Not IsMissing(XPos) And Not IsMissing(YPos) Then
If Center = True Then Err.Raise 5
Dim hDCScreen As LongPtr, DPI_X As Long, DPI_Y As Long
hDCScreen = GetDC(NULL_PTR)
If hDCScreen <> NULL_PTR Then
DPI_X = GetDeviceCaps(hDCScreen, LOGPIXELSX)
DPI_Y = GetDeviceCaps(hDCScreen, LOGPIXELSY)
ReleaseDC NULL_PTR, hDCScreen
End If
PropXPos = CLng(XPos / (1440 / DPI_X))
PropYPos = CLng(YPos / (1440 / DPI_Y))
End If
PropHelpFile = HelpFile
PropContext = Context
PropCenter = Center
If MaxLength < 0 Then Err.Raise 380
PropMaxLength = MaxLength
PropPassword = Password
PropLangID = GetUserDefaultUILanguage() And &HFF&
PropWinHelpRunning = False
Dim hWndParent As LongPtr
If Not Screen.ActiveForm Is Nothing Then
hWndParent = Screen.ActiveForm.hWnd
Else
hWndParent = GetActiveWindow()
End If
Dim DLGIB As DLGINPUTBOX
With DLGIB
.dwStyle = DS_3DLOOK Or DS_SETFONT Or DS_MODALFRAME Or WS_POPUP Or WS_CAPTION Or WS_SYSMENU
If PropCenter = True Then .dwStyle = .dwStyle Or DS_CENTER
.dwExStyle = 0
.cItems = 5
.X = 55
.Y = 22
Select Case PropLangID
Case &H7 ' German
.CX = 243
Case Else
.CX = 238
End Select
.CY = 74
.Menu = 0
.ClassName = 0
.Title = 0
.FontSize = 9
CopyMemory ByVal VarPtr(.FontName(0)), ByVal StrPtr("MS Shell Dlg"), 24
.Item1_dwStyle = SS_LEFT Or SS_NOPREFIX Or WS_CHILD Or WS_VISIBLE Or WS_GROUP
.Item1_dwExStyle = 0
.Item1_X = 6
.Item1_Y = 6
.Item1_CX = 178
.Item1_CY = 45
.Item1_wID = ID_STATIC
.Item1_ClassName = &HFFFF
.Item1_ClassAtom = &H82 ' STATIC
.Item1_Title = 0
.Item1_Data = 0
.Item2_dwStyle = ES_LEFT Or ES_AUTOHSCROLL Or WS_CHILD Or WS_VISIBLE Or WS_BORDER Or WS_TABSTOP
If PropPassword = True Then .Item2_dwStyle = .Item2_dwStyle Or ES_PASSWORD
.Item2_dwExStyle = 0
.Item2_X = 6
.Item2_Y = 56
Select Case PropLangID
Case &H7 ' German
.Item2_CX = 232
Case Else
.Item2_CX = 226
End Select
.Item2_CY = 12
.Item2_wID = ID_EDIT
.Item2_ClassName = &HFFFF
.Item2_ClassAtom = &H81 ' EDIT
.Item2_Title = 0
.Item2_Data = 0
Dim ButtonWidth As Long
Select Case PropLangID
Case &H7 ' German
ButtonWidth = 45
Case Else
ButtonWidth = 40
End Select
.Item3_dwStyle = BS_DEFPUSHBUTTON Or WS_CHILD Or WS_VISIBLE Or WS_GROUP Or WS_TABSTOP
.Item3_dwExStyle = 0
.Item3_X = 192
.Item3_Y = 6
.Item3_CX = ButtonWidth
.Item3_CY = 14
.Item3_wID = ID_OK
.Item3_ClassName = &HFFFF
.Item3_ClassAtom = &H80 ' BUTTON
.Item3_Title = 0
.Item3_Data = 0
.Item4_dwStyle = BS_PUSHBUTTON Or WS_CHILD Or WS_VISIBLE Or WS_GROUP Or WS_TABSTOP
.Item4_dwExStyle = 0
.Item4_X = 192
.Item4_Y = 23
.Item4_CX = ButtonWidth
.Item4_CY = 14
.Item4_wID = ID_CANCEL
.Item4_ClassName = &HFFFF
.Item4_ClassAtom = &H80 ' BUTTON
.Item4_Title = 0
.Item4_Data = 0
.Item5_dwStyle = BS_PUSHBUTTON Or WS_CHILD Or WS_VISIBLE Or WS_GROUP Or WS_TABSTOP
.Item5_dwExStyle = 0
.Item5_X = 192
.Item5_Y = 40
.Item5_CX = ButtonWidth
.Item5_CY = 14
.Item5_wID = ID_HELP
.Item5_ClassName = &HFFFF
.Item5_ClassAtom = &H80 ' BUTTON
.Item5_Title = 0
.Item5_Data = 0
End With
DialogBoxIndirectParam App.hInstance, VarPtr(DLGIB), hWndParent, AddressOf DlgProc, StrPtr(Prompt)
InputBox = PropInput
PropInput = vbNullString
PropTitle = vbNullString
PropDefault = vbNullString
PropXPos = Empty
PropYPos = Empty
PropHelpFile = vbNullString
End Function
Private Function DlgProc(ByVal hDlg As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Select Case wMsg
Case WM_INITDIALOG
SetWindowText hDlg, StrPtr(PropTitle)
If PropHelpFile = vbNullString Then ShowWindow GetDlgItem(hDlg, ID_HELP), SW_HIDE
SetDlgItemText hDlg, ID_STATIC, lParam
SendDlgItemMessage hDlg, ID_EDIT, EM_SETLIMITTEXT, PropMaxLength, ByVal 0&
If Not PropDefault = vbNullString Then
SetDlgItemText hDlg, ID_EDIT, StrPtr(PropDefault)
SendDlgItemMessage hDlg, ID_EDIT, EM_SETSEL, 0, -1
End If
Dim ButtonText(0 To 2) As String
Select Case PropLangID
Case &H7 ' German
ButtonText(0) = "OK"
ButtonText(1) = "Abbrechen"
ButtonText(2) = "&Hilfe"
Case &HC ' French
ButtonText(0) = "OK"
ButtonText(1) = "Annuler"
ButtonText(2) = "&Aide"
Case &H1D ' Swedish
ButtonText(0) = "OK"
ButtonText(1) = "Avbryt"
ButtonText(2) = "&Hjälp"
Case Else
ButtonText(0) = "OK"
ButtonText(1) = "Cancel"
ButtonText(2) = "&Help"
End Select
SetDlgItemText hDlg, ID_OK, StrPtr(ButtonText(0))
SetDlgItemText hDlg, ID_CANCEL, StrPtr(ButtonText(1))
SetDlgItemText hDlg, ID_HELP, StrPtr(ButtonText(2))
Dim WndRect As RECT, hMonitor As LongPtr, MI As MONITORINFO
GetWindowRect hDlg, WndRect
hMonitor = MonitorFromWindow(hDlg, MONITOR_DEFAULTTOPRIMARY)
MI.cbSize = LenB(MI)
GetMonitorInfo hMonitor, MI
If PropCenter = False Then
Dim X As Long, Y As Long
If IsEmpty(PropXPos) Or IsEmpty(PropYPos) Then
X = MI.RCWork.Left + (((MI.RCWork.Right - MI.RCWork.Left) - (WndRect.Right - WndRect.Left)) \ 2)
Y = MI.RCWork.Top + (((MI.RCWork.Bottom - MI.RCWork.Top) - (WndRect.Bottom - WndRect.Top)) \ 3)
Else
X = PropXPos
Y = PropYPos
End If
SetWindowPos hDlg, NULL_PTR, X, Y, 0, 0, SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
End If
DlgProc = 1
Exit Function
Case WM_COMMAND
Select Case LoWord(CLng(wParam))
Case ID_OK
Dim Length As Long
Length = CLng(SendDlgItemMessage(hDlg, ID_EDIT, WM_GETTEXTLENGTH, 0, 0))
PropInput = Space$(Length)
GetDlgItemText hDlg, ID_EDIT, StrPtr(PropInput), Length + 1
EndDialog hDlg, 0
DlgProc = 1
Exit Function
Case ID_CANCEL
EndDialog hDlg, 0
DlgProc = 1
Exit Function
Case ID_HELP
RunHelp hDlg
DlgProc = 1
Exit Function
End Select
Case WM_HELP
RunHelp hDlg
DlgProc = 1
Exit Function
Case WM_DESTROY
If PropWinHelpRunning = True Then WinHelp hDlg, NULL_PTR, HELP_QUIT, 0
DlgProc = 1
Exit Function
End Select
DlgProc = 0
End Function
Private Sub RunHelp(ByVal hDlg As LongPtr)
If Not PropHelpFile = vbNullString Then
Dim Success As Boolean
If LCase$(Right$(PropHelpFile, 4)) = ".hlp" Then
If PropContext = 0 Then
Success = CBool(WinHelp(hDlg, StrPtr(PropHelpFile), HELP_INDEX, 0) <> 0)
Else
Success = CBool(WinHelp(hDlg, StrPtr(PropHelpFile), HELP_CONTEXT, PropContext) <> 0)
End If
PropWinHelpRunning = Success
Else
If PropContext = 0 Then
Success = CBool(HtmlHelp(hDlg, StrPtr(PropHelpFile), HH_DISPLAY_TOPIC, 0) <> 0)
Else
Success = CBool(HtmlHelp(hDlg, StrPtr(PropHelpFile), HH_HELP_CONTEXT, PropContext) <> 0)
End If
End If
If Success = False Then
Dim Text As String
Select Case PropLangID
Case &H7 ' German
Text = "Hilfe kann nicht angezeigt werden"
Case &HC ' French
Text = "Impossible d'afficher l'aide"
Case &H1D ' Swedish
Text = "Det gick inte att visa hjälpen"
Case Else
Text = "Unable to display help"
End Select
MessageBox hDlg, StrPtr(Text), NULL_PTR, vbCritical + vbOKOnly
End If
End If
End Sub
Private Function LoWord(ByVal DWord As Long) As Integer
If DWord And &H8000& Then
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Thanks for this addition, personally I was just too lazy to describe this whole dialogue myself, so I took the ready-made version from the library msvbvm60.dll. I'm glad you took the time. Do I understand correctly that no DLL is needed here?
Re: InputBox with full unicode support v. 2.5 and v. 2.55
By the way, I saw another very perverted code for InputBox somewhere, which called the MessageBoxW API function and through the API completely redesigned the dialog box for text input, through subclassing, a complete perversion, but it worked
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by HackerVlad
Do I understand correctly that no DLL is needed here?
Yes, that's why I mentioned it can be used to replace the InputBox in x64 twinBASIC as well.
Just added a Password param, when set to True the edit box is created with ES_PASSWORD.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by HackerVlad
But in twinBASIC, the InputBox function does support unicode.
Yes sure. But just in case. For example if someone needs the Center, MaxLength or Password feature it could be replaced. Also the localization is not (yet) available in twinBASIC.
And on the other side I just wanted to make the exercise to use DialogBoxIndirectParam as there is no code out there of it.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Yes, we talked about this a year ago in this topic. And I honestly didn't expect you to decide to write this code anyway. Well, it's good that you took the time for this. Of course, I could have written this code too, but I couldn't afford to spend a couple of days on it then...
Thank you very much again. I think someone will definitely need it.
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by HackerVlad
By the way, I saw another very perverted code for InputBox somewhere, which called the MessageBoxW API function and through the API completely redesigned the dialog box for text input, through subclassing, a complete perversion, but it worked
My cTaskDialog class has a custom option to add a TextBox to a task dialog, for a slightly more elegant but still hacky solution...
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Originally Posted by Krool
Yes sure. But just in case. For example if someone needs the Center, MaxLength or Password feature it could be replaced. Also the localization is not (yet) available in twinBASIC.
And on the other side I just wanted to make the exercise to use DialogBoxIndirectParam as there is no code out there of it.
What kind of localization do you mean? You can create localized resources (for other than StringTables which are localized in the JSON editor) by putting them in subfolders named LCID_xxxx where xxxx is a Hex value. The ANSI code page can be set to either the one at build time, the one at runtime, or a specific one.
But yes cool to see DialogBoxIndirectParam example. I did some examples with dialog resources in the form of property sheets aimed at a Control Panel Applet (where a regular Form is a no-go for a classic .cpl), but not as a plain dialog, and definitely not constructing the template manually.
Last edited by fafalone; Feb 20th, 2026 at 11:55 PM.
Reply With Quote
Originally Posted by yokesee
Re: InputBox with full unicode support v. 2.5 and v. 2.55
Re: InputBox with full unicode support v. 2.5 and v. 2.55
