Every time I've searched the internet on how to make the InputBox function support Unicode, the answers were to make your own InputBox using a form, a couple of buttons and a TextBox that supports Unicode. But this seems like a waste of a perfectly fine InputBox that you already have! :D
The original InputBox from VB6 is actually a simple, run-of-the-mill Windows Dialog and as such it is perfectly capable of displaying Unicode characters on its own if it weren't for VB6 messing things up in the background. It turns out the solution is rather short and sweet so I've put together a small "cIB" class to wrap up the InputBox.
As a bonus I've also included the possibility to use a "Password Char" to mask user input (same as a regular TextBox). Another improvement over the original InputBox is that now you can tell whether the user selected "OK" or "Cancel" without entering any text. Unicode characters can be used everywhere (in the Titlebar, Prompt and Edit box). Here's what it looks like:
Image may be NSFW.
Clik here to view.
The class only has one property which is also marked as "Default" to keep the syntax as short as possible. It is also "Predeclared" so it can be used "as is" without declaring new instances:
cIB.cls
Basically the whole idea is to install a CBT (Computer Based Training) hook that looks for the InputBox Dialog and then subclasses it and disables itself on the fly:
mdlInputBox.bas
And of course the ubiquitous ISubclass stub (to use with Implements):
ISubclass.cls
That's all there is to it. Here's a small demo program with the InputBox showing some Japanese haikus as well as the password char in action:
InputBoxTest.zip
The original InputBox from VB6 is actually a simple, run-of-the-mill Windows Dialog and as such it is perfectly capable of displaying Unicode characters on its own if it weren't for VB6 messing things up in the background. It turns out the solution is rather short and sweet so I've put together a small "cIB" class to wrap up the InputBox.
As a bonus I've also included the possibility to use a "Password Char" to mask user input (same as a regular TextBox). Another improvement over the original InputBox is that now you can tell whether the user selected "OK" or "Cancel" without entering any text. Unicode characters can be used everywhere (in the Titlebar, Prompt and Edit box). Here's what it looks like:
Image may be NSFW.
Clik here to view.
The class only has one property which is also marked as "Default" to keep the syntax as short as possible. It is also "Predeclared" so it can be used "as is" without declaring new instances:
cIB.cls
Code:
Option Explicit
Implements ISubclass
Private Const sEmpty As String = "", WM_SHOWWINDOW = &H18, WM_APP = &H8000&, WM_COMMAND = &H111, WM_SETTEXT = &HC, WM_GETTEXT = &HD, WM_GETTEXTLENGTH = &HE, EM_SETPASSWORDCHAR = &HCC, EM_SETSEL = &HB1
Private Declare Function SendMessageVal 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 PostMessageVal Lib "user32" Alias "PostMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private sInputText As String, sPrompt As String, sTitle As String, sPasswordChar As String, bOkayClicked As Boolean
Public Property Get InputBoxW(Optional Prompt As String, Optional Title As String, Optional Default As String, Optional PasswordChar As String, Optional bCanceledInput As Boolean) As String
If EnableCBTHook(Me) Then ' Install the CBT (Computer Based Training) hook, subclass the InputBox Dialog and initialize the parameters
If Len(Prompt) Then sPrompt = Prompt
If Len(Title) Then sTitle = Title
If Len(PasswordChar) Then sPasswordChar = PasswordChar
If bCanceledInput Then sInputText = sEmpty
If Len(Default) Then sInputText = Default
InputBox sPrompt ' Display the classic VB6 InputBox Dialog
bCanceledInput = Not bOkayClicked ' Return user's choice
If Not bCanceledInput Then InputBoxW = sInputText
bOkayClicked = False: sPrompt = sEmpty: sTitle = sEmpty: sPasswordChar = sEmpty ' Reset parameters for next use
End If
End Property
Public Property Let InputBoxW(Optional Prompt As String, Optional Title As String, Optional Default As String, Optional PasswordChar As String, Optional bCanceledInput As Boolean, InputBoxW As String)
' Property Let doesn't do anything but it's required to mark this property as "Default" for our class.
End Property
Private Function ISubclass_WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
Dim bDiscardMessage As Boolean
Select Case hWnd
Case hWndInputBox
Select Case uMsg
Case WM_SHOWWINDOW ' The InputBox Dialog is about to be displayed, post a custom WM_APP message to the end of the queue
PostMessageVal hWndInputBox, WM_APP, 0&, 0&
Case WM_APP ' Custom message received, the InputBox Dialog is fully created and ready to be modified
If Len(sTitle) Then SetWindowText hWndInputBox, StrPtr(sTitle) ' Set the titlebar text
If Len(sPrompt) Then SendMessageVal hWndStatic, WM_SETTEXT, 0&, StrPtr(sPrompt) ' Set the "Prompt" text
If Len(sPasswordChar) Then SendMessageVal hWndEdit, EM_SETPASSWORDCHAR, CLng(AscB(sPasswordChar)), 0& ' Optional password char to mask user input
If Len(sInputText) Then SendMessageVal hWndEdit, WM_SETTEXT, 0&, StrPtr(sInputText): SendMessageVal hWndEdit, EM_SETSEL, 0&, -1& ' Set and select "Default" text
Case WM_COMMAND
If wParam = 1 Then ' User clicked the "OK" button or pressed Enter to close the InputBox Dialog
Dim lTextLen As Long
lTextLen = SendMessageVal(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&) ' Get the text length
sInputText = String$(lTextLen, vbNullChar): bOkayClicked = True
SendMessageVal hWndEdit, WM_GETTEXT, lTextLen + 1, StrPtr(sInputText) ' Read the actual text entered by the user
End If
End Select
End Select
If Not bDiscardMessage Then ISubclass_WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End FunctionmdlInputBox.bas
Code:
Option Explicit
Private Const DIALOG_CLASS As String = "#32770", EDIT_CLASS As String = "Edit", STATIC_CLASS As String = "Static"
Private Const WH_CBT = 5, WM_NCDESTROY = &H82, HCBT_CREATEWND = 3, MAX_PATH = 260
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal IDHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function GetWindowSubclass Lib "comctl32" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Public Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hWnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function IsChild Lib "user32" (ByVal hWndParent As Long, ByVal hWnd As Long) As Long
Private m_CBTHook As Long, m_SubclassInputBox As cIB
Public hWndInputBox As Long, hWndEdit As Long, hWndStatic As Long
Public Function EnableCBTHook(SubclassInputBox As cIB) As Boolean
If m_CBTHook = 0 Then
Set m_SubclassInputBox = SubclassInputBox: hWndInputBox = 0: hWndStatic = 0: hWndEdit = 0
m_CBTHook = SetWindowsHookEx(WH_CBT, AddressOf CBTHookProc, 0, App.ThreadID) ' Set a CBT (Computer Based Training) hook to watch for the InputBox Dialog
If m_CBTHook Then EnableCBTHook = True
End If
End Function
Private Function DisableCBTHook() As Boolean
If m_CBTHook Then If UnhookWindowsHookEx(m_CBTHook) Then m_CBTHook = 0: DisableCBTHook = True
End Function
Private Function CBTHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode = HCBT_CREATEWND Then ' Watch for new windows being created
Dim sClassName As String, lClassLen As Long
sClassName = String$(MAX_PATH, vbNullChar)
lClassLen = GetClassName(wParam, StrPtr(sClassName), Len(sClassName)) ' Get the class name from hWnd
Select Case Left$(sClassName, lClassLen)
Case DIALOG_CLASS ' This is the InputBox Dialog window
hWndInputBox = wParam
Case STATIC_CLASS ' This is the Static control for displaying the InputBox "Prompt"
hWndStatic = wParam
Case EDIT_CLASS ' This is the Edit control for entering text in the InputBox Dialog
hWndEdit = wParam
End Select
If hWndInputBox Then
If hWndStatic Then
If hWndEdit Then
If IsChild(hWndInputBox, hWndStatic) And IsChild(hWndInputBox, hWndEdit) Then ' Sanity check to make sure this is indeed the InputBox Dialog we're looking for
If DisableCBTHook Then SubclassWnd hWndInputBox, m_SubclassInputBox ' Remove the CBT hook and subclass the InputBox Dialog
End If
End If
End If
End If
End If
CBTHookProc = CallNextHookEx(m_CBTHook, nCode, wParam, lParam)
End Function
Public Sub SubclassWnd(hWnd As Long, Subclass As ISubclass, Optional dwRefData As Long)
Dim uIdSubclass As Long
uIdSubclass = ObjPtr(Subclass)
If Not IsWndSubclassed(hWnd, uIdSubclass) Then SetWindowSubclass hWnd, AddressOf WndProc, uIdSubclass, dwRefData
End Sub
Private Sub UnSubclassWnd(hWnd As Long, Subclass As ISubclass)
Dim uIdSubclass As Long
uIdSubclass = ObjPtr(Subclass)
If IsWndSubclassed(hWnd, uIdSubclass) Then RemoveWindowSubclass hWnd, AddressOf WndProc, uIdSubclass
End Sub
Private Function IsWndSubclassed(hWnd As Long, uIdSubclass As Long, Optional dwRefData As Long) As Boolean
IsWndSubclassed = GetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
End Function
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Subclass As ISubclass, ByVal dwRefData As Long) As Long
Select Case uMsg
Case WM_NCDESTROY ' Remove subclassing as the window is about to be destroyed
UnSubclassWnd hWnd, Subclass
WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
Case Else
WndProc = Subclass.WndProc(hWnd, uMsg, wParam, lParam, dwRefData)
End Select
End FunctionISubclass.cls
Code:
Option Explicit
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
End FunctionInputBoxTest.zip