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.
Printable View
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.
Code:Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 19.11.2023 by HackerVlad //
'// e-mail: [email protected] //
'// Version 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 ' Analog of DS_CENTER
' 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 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) ' The very cherished code that calls InputBox
End If
InputBoxW = InputText
InputText = vbNullString
TitleText = vbNullString
DefaultText = 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 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
' Determining the size of the window
GetWindowRect hwndDlg, rct
If CenterOnWorkspace = False Then ' Standard alignment
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 ' Centering on the working area of the screen (analogous to the DS_CENTER style)
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
I downloaded the source code of the InputBox function. I want to note that this code is very similar to the original code from Microsoft. But I wrote it myself after reading a lot of documentation. In fact, the dialog box itself is located in the library resources msvbvm60.dll and it is called by just one DialogBoxParamW function. Of course, I admire the work done by the VanGoghGaming user, but the idea of hacking a dialog box through hooks is the wrong direction. Mine is much easier.
This is very nice indeed but where did you get this magic constant, "4031"?Quote:
Originally Posted by HackerVlad
I'm glad you liked my code. This is the resource number of the dialog box. I am sure that this constant will always be the same.Quote:
Originally Posted by VanGoghGaming
You can see this for yourself by opening the Resource Hacker program.
Ahh, the "Resource Hacker" program, I see now you're not called HackerVlad for nothing haha! Good one, cheers! :D
Truth be told, I never quite liked using "SetWindowsHookEx" to find the "InputBox Dialog" window but the whole idea here was to make use of the already existing VB6 InputBox function. Now thanks to you I have learned that "InputBox" calls "DialogBoxParamA" under the covers so the problem can be simplified by setting up a basic trampoline on the "DialogBoxParamA" function:
mdlInputBox module:
That's all there is to it, now the "InputBox" will call our custom "HookedDialogBoxParamA" function so that we can gain access to the original DLGPROC and obtain the InputBox hWnd so we can finally subclass it!Code:Private m_lSubclassInputBox As Long, lpDialogBoxParamA As Long, lpOriginalDlgProc As Long, baOriginalDialogBoxParamA(0 To 5) As Byte, baTrampoline(0 To 5) As Byte
Public hWndInputBox As Long
Public Function InputBoxHook(SubclassInputBox As ISubclass) As Boolean
If lpDialogBoxParamA = 0 Then
lpDialogBoxParamA = GetProcAddress(GetModuleHandleW(StrPtr("user32")), "DialogBoxParamA") ' Get the address of the "DialogBoxParamA" function
ReadProcessMemory -1&, lpDialogBoxParamA, VarPtr(baOriginalDialogBoxParamA(0)), 6&, 0& ' Save the first 6 bytes (the size of the trampoline) to be restored later
baTrampoline(0) = &H68 ' push
PutMem4 baTrampoline(1), AddressOf mdlInputBox.HookedDialogBoxParamA ' Set up the trampoline jump to our custom "HookedDialogBoxParamA" function
baTrampoline(5) = &HC3 ' ret
End If
m_lSubclassInputBox = ObjPtr(SubclassInputBox): hWndInputBox = 0 ' Save a reference to our cIB object for subclassing and reset the InputBox window handle
InputBoxHook = WriteProcessMemory(-1&, lpDialogBoxParamA, VarPtr(baTrampoline(0)), 6&, 0&) ' Now the InputBox function will call our custom "HookedDialogBoxParamA" function instead
End Function
Private Function HookedDialogBoxParamA(ByVal hInstance As Long, ByVal lpTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
lpOriginalDlgProc = lpDialogFunc ' Save the address of the original DLGPROC callback function (we need to call this later)
WriteProcessMemory -1&, lpDialogBoxParamA, VarPtr(baOriginalDialogBoxParamA(0)), 6&, 0& ' Restore the original "DialogBoxParamA" API function
HookedDialogBoxParamA = DialogBoxParam(hInstance, lpTemplateName, hWndParent, AddressOf mdlInputBox.DlgProc, dwInitParam) ' Call "DialogBoxParamA" using our custom "DlgProc" instead
End Function
Private Function DlgProc(ByVal hWndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If hWndInputBox = 0 Then hWndInputBox = hWndDlg: SubclassWnd hWndInputBox, m_lSubclassInputBox ' This is the hWnd of the InputBox Dialog window so we can finally subclass it!
DlgProc = CallWindowProc(lpOriginalDlgProc, hWndDlg, uMsg, wParam, lParam) ' Call the original DLGPROC callback function to process the rest of messages
End Function
I still prefer going the subclassing way because it allows discarding messages that we don't want to process. For example the "WM_COMMAND" message can be discarded if the user clicks "OK" when the InputBox is empty and the "RequireInput" property is True! :D
Please provide the full source code, and it is better to have the project in the ZIP archive right away.
Sure, it's pretty much the same project as the one in my sig (the one using "SetWindowsHookEx" to find the InputBox). The code highlighted above is the only modification to remove the hooking that we both didn't quite like! ;)
Attachment 189401
Thank you for your work! Can you tell me where you have the code that calls InputBox
By the way, your method is still worse than mine, since it requires a manifest. My code works without a manifest.
The original InputBox function is called inside the "cIB" class that embeds all other additional properties and methods for this enhanced InputBox improvement:
It's not really a question about whose code is better, it's not a competition, they are both valid approaches. I have learned much from your code.Code:Public Property Get InputBoxW(Optional Prompt As String, Optional Title As String, Optional Default As String, Optional bCanceledInput As Boolean, Optional xPos, Optional yPos) As String
If InputBoxHook(Me) Then ' Hook the DialogBoxParamA API function used to create the InputBox Dialog, subclass it and initialize the parameters
If Len(Prompt) Then sPrompt = Prompt
If Len(Title) Then sTitle = Title
sInputText = Default
InputBox sPrompt, , , xPos, yPos ' Display the classic VB6 InputBox Dialog
bCanceledInput = Not bOkayClicked ' Return user's choice
If bOkayClicked Then InputBoxW = sInputText
bOkayClicked = False: sPrompt = vbNullString: sTitle = vbNullString: sPasswordChar = vbNullString ' Reset parameters for next use
If Not m_bPreserveFont Then Set m_objFont = Nothing
End If
End Property
The manifest is not required and can be safely removed from the project. I just like to include a manifest in all my projects for the modern theme, that's all.
I've already tried it, your code doesn't work without a manifest! Here, take and delete the manifest and check for yourself.
In fact, I am very glad that you learned a lot from my code, and I noticed that you used some of my functions and constants. I'm glad I helped you.
If the InputBox is called classic in your code, then it cannot support unicode input without styling the window with a manifest. This limitation is due to the fact that the DialogboxparamA function is called instead of DialogBoxParamW
This is very interesting, I had no idea the manifest (or lack thereof) would have this unintended effect! I thought everybody would be using them nowadays... It's easy to fix it though, just call "DialogBoxParamW" in the "HookedDialogBoxParamA" function:
Code:Private Function HookedDialogBoxParamA(ByVal hInstance As Long, ByVal lpTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
lpOriginalDlgProc = lpDialogFunc ' Save the address of the original DLGPROC callback function (we need to call this later)
WriteProcessMemory -1&, lpDialogBoxParamA, VarPtr(baOriginalDialogBoxParamA(0)), 6&, 0& ' Restore the original "DialogBoxParamA" API function
HookedDialogBoxParamA = DialogBoxParamW(hInstance, lpTemplateName, hWndParent, AddressOf mdlInputBox.DlgProc, dwInitParam) ' Call "DialogBoxParamW" using our custom "DlgProc" instead
End Function
It's good that I pointed out this error to you. In general, get used to always using W-functions!
By the way, correct the name of the function in the comments.
More from wishes:
You have the ability to change the Height? Why don't you make AutoHeight depending on the height of the text? Use the GetTextExtentPoint32 (gdi32.dll) function to do this.
Ugh, I really don't feel like going down that rabbit hole. There is no way of knowing how does the Static control from the InputBox Dialog break down the text into multiple lines so calculating the exact height would be a nightmare... Currently I am using a rough percentage approximation to increase the height and it seems to be good enough for most purposes. :)
VanGoghGaming, thank you very much for your work, but I do not agree with your decision, I do not like your code, which first calls the original code from Microsoft, and then calls your code through subclasses.
I've been thinking about your code for a long time and came to the conclusion that WM_INITDIALOG is processed first, where the Microsoft code is triggered, this code centers the window and sets the caption texts, and then your new code is triggered in the WM_SHOWWINDOW event.
In total, it turns out that the statics-labels are redrawn as many as two times. But everything could be done once in WM_INITDIALOG, but for this you need to abandon the Microsoft code.
And I still don't understand why we should use subclassing technology if we have direct access to the callback function of the dialog box!?
Nothing is drawn in the "WM_INITDIALOG" event (or even "WM_SHOWWINDOW" for that matter), since the window is not yet visible on screen. Also, the DLGPROC callback function does not have the ability to ignore certain messages that we do not want to be processed:
So either way the message is processed. Subclassing can resolve this shortcoming. I did mention this in post #8 above:Quote:
Typically, the dialog box procedure should return TRUE if it processed the message, and FALSE if it did not. If the dialog box procedure returns FALSE, the dialog manager performs the default dialog operation in response to the message.
In order to completely abandon the Microsoft code you would need to stop using the "4031" resource and make a new template from scratch. This way you could completely control the size and position of all "InputBox" elements, as well as including additional buttons, labels, icons, whistles and bells. ;)Quote:
For example the "WM_COMMAND" message can be discarded if the user clicks "OK" when the InputBox is empty and the "RequireInput" property is True!
However I enjoy reusing existing functionality such as the ability to select the initial starting position of the InputBox or leave it as it is, centered on screen. At the end of the day, it's just an "InputBox" and there are many ways to skin a cat. :D
I just want to point out, that my method has the advantage of localization of the [OK] [Cancel] buttons to the system's language,
but in your method it's always in English.
It is also wrapped up in one, self contained, no API, function.
Unless you MUST remove the harmless icon, then you must use the hook.
Button text could be changed just the same as the other text in the InputBox. And we're back to skinning the cat! :)
You are wrong! 'cause you don't know on what system your code is running, unless you want to translate to every possible language...
There are many ways to skin a cat, but only one proper way...
Who will need it, I think it will not be difficult to find out the current language of the Windows system and translate the language of these buttons if necessaryQuote:
Originally Posted by Dry Bone
First of all, I want to note that the initial installation of window headers is performed by the original Microsoft code in the WM_INITDIALOG event. Not in WM_SHOWWINDOW in any way.Quote:
Originally Posted by VanGoghGaming
In WM_SHOWWINDOW, you then change the window labels yourself for the second time. I also drew attention to the fact that the window labels will change twice.
So, let's continue this topic. I have written a new version of the module to call the unicode InputBox. Now my function is almost the same as Microsoft's. Now it is possible to specify the coordinates of the dialog box and also added a Help button. And of course, I enabled the ability to call help files.
I also want to point out the advantages of my function:
1. Does not require manifests
2. There are no complicated hooks
3. No need to use sophisticated subclassing technology
4. There is no need for any jumps and redirects
5. The function is written very clearly, almost like in the original source code from Microsoft
6. The window alignment is exactly the same as in the original InputBox as in Microsoft
7. An additional feature has been added to align the window to the center of the working area of the screen
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
Nice work! However you should name your project files and .exe using simple A-Z (0-128) letters. Your ASCII code page of Russian? gives funny chars on any different locale.Quote:
Originally Posted by HackerVlad
Which I suppose is how you were able to sneak a .exe file in the zip!! haha
Now please give it the option to change the font and size. And then, do the same for the MessageBox next !!! :D just kidding.
Cheers
Edit - after opening the project, it's impossible to tell if Unicode works, you need to read the strings from a Unicode text file the way VanGoghGaming does.
This is what we see on English locale VB:
Also, this function is not VB6 IDE safe. Seems like a subclassing problem. Your project literally * disappeared * after closing the p-code exe in VB.Code:str = InputBoxW(0, "Êèòàéñêèé ÿçûê ïðèâåòñòâóåòñÿ. " & vbNewLine & "Ââåäèòå êèòàéùèíó (íàïðèìåð " & ChrW(&H4EBA) & "):", "Äðóæáà íàðîäîâ " & ChrW(-29686), "Ýòî êèòàéñêèé ñèìâîë äðóæáû - " & ChrW(-29686))
Code:Private Function DlgProc(ByVal hwndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Yes, I used Russian. You can easily rewrite it yourself as you need. The most important thing is that the module itself works. I don't use any subclasses.
I did not focus on changing the font, font size, window size, window and font size, or changing the color. How did VanGoghGaming do it
How to change the text box entered to display multiple lines of text wrapped.
How to set the text box background color. Or make the text transparent.
I just didn't have the need to type a lot of lines into a text field. But another forum user is asking the same question here: https://www.vbforums.com/showthread....=1#post5631316
There is already almost correct code written there that needs to be changed so that everything works.
I don't understand why you need to enter a lot of lines?
Code:Option Explicit
'////////////////////////////////////////////
'// Module for calling Unicode InputBox //
'// Copyright (c) 2024-02-01 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
Good job HackerVlad put this in CodeBank