Extended InputBox with full Unicode support for VB/VBA

InputBoxEx.bas

Option Explicit

Private Type WindowData
    pfnBase As LongPtr
End Type

Private Const WindowDataPropName As String = "InputBoxWndData"

Private Const WH_CBT As Long = 5
Private Const HCBT_CREATEWND As Long = 3

Private Const GWLP_WNDPROC As Long = -4

Private Const WM_NCDESTROY As Long = &H82&
Private Const WM_INITDIALOG As Long = &H110&
Private Const WM_COMMAND As Long = &H111&

Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32.dll" () As Long
Private Declare PtrSafe Function CoTaskMemAlloc Lib "ole32.dll" (ByVal cb As Long) As LongPtr
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr)
Private Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWndParent As LongPtr, ByVal hWndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
Private Declare PtrSafe Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextW" (ByVal hWnd As LongPtr, ByVal lpString As LongPtr, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthW" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function SetWindowText Lib "user32.dll" Alias "SetWindowTextW" (ByVal hWnd As LongPtr, ByVal lpString As LongPtr) As Boolean
Private Declare PtrSafe Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Message As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrW" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As LongPtr) As Boolean
Private Declare PtrSafe Function CallNextHookEx Lib "user32.dll" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Private g_hHook As LongPtr
Private g_strPrompt As String
Private g_strTitle As Variant
Private g_strDefault As Variant
Private g_strResult As String

' Retrieve window text as Unicode (UTF-16)
Private Function GetWndText(ByVal hWnd As LongPtr) As String
    Dim TextLength As Long
    TextLength = GetWindowTextLength(hWnd)
    GetWndText = String$(TextLength + 1, 0)
    Call GetWindowText(hWnd, StrPtr(GetWndText), TextLength + 1)
    GetWndText = Left$(GetWndText, TextLength)
End Function

Private Function InputBoxWndProc(ByVal hWnd As LongPtr, ByVal Message As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim d As WindowData, p As LongPtr
    p = GetProp(hWnd, WindowDataPropName)
    If p = 0 Then Exit Function
    Call CopyMemory(d, ByVal p, Len(d))

    If Message = WM_COMMAND Then
        ' "1" is IDOK, meaning "OK was pressed or Enter key was pressed"
        If (wParam And &HFFFF&) = 1 Then
            Dim hWndText As LongPtr
            Dim TextLength As Long
            ' Find edit control
            hWndText = FindWindowEx(hWnd, 0, "Edit", vbNullString)
            If hWndText <> 0 Then
                ' Retrieve control text as Unicode (UTF-16)
                g_strResult = GetWndText(hWndText)
            End If
        End If
    End If

    InputBoxWndProc = CallWindowProc(d.pfnBase, hWnd, Message, wParam, lParam)

    ' After WM_INITDIALOG, window controls are created, so we can set control text
    If Message = WM_INITDIALOG Then
        Dim hWndTemp As LongPtr
        If Not IsEmpty(g_strTitle) And Not IsMissing(g_strTitle) Then
            Call SetWindowText(hWnd, StrPtr(CStr(g_strTitle) + vbNullChar))
        End If
        hWndTemp = FindWindowEx(hWnd, 0, "Static", vbNullString)
        If hWndTemp <> 0 Then
            Call SetWindowText(hWndTemp, StrPtr(g_strPrompt + vbNullChar))
        End If
        If Not IsEmpty(g_strDefault) And Not IsMissing(g_strDefault) Then
            hWndTemp = FindWindowEx(hWnd, 0, "Edit", vbNullString)
            If hWndTemp <> 0 Then
                Call SetWindowText(hWndTemp, StrPtr(CStr(g_strDefault) + vbNullChar))
            End If
        End If
    ElseIf Message = WM_NCDESTROY Then
        ' Clean up
        Call SetWindowLongPtr(hWnd, GWLP_WNDPROC, d.pfnBase)
        Call CoTaskMemFree(p)
    End If
End Function

Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    CBTProc = CallNextHookEx(g_hHook, nCode, wParam, lParam)
    ' Handle window creation
    If nCode = HCBT_CREATEWND Then
        ' Start hook WindowProc
        ' To use CallWindowProc, keep old WindowProc to the memory
        Dim d As WindowData, p As LongPtr
        p = CoTaskMemAlloc(Len(d))
        If p <> 0 Then
            Call SetProp(wParam, WindowDataPropName, p)
            d.pfnBase = SetWindowLongPtr(wParam, GWLP_WNDPROC, AddressOf InputBoxWndProc)
            Call CopyMemory(ByVal p, d, Len(d))
        End If
        Call EndHook
    End If
End Function

Private Sub StartHook()
    If g_hHook <> 0 Then
        Exit Sub
    End If
    g_hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, 0, GetCurrentThreadId())
End Sub

Private Sub EndHook()
    If g_hHook = 0 Then Exit Sub
    Call UnhookWindowsHookEx(g_hHook)
    g_hHook = 0
End Sub

' Same parameter for InputBox except that all Unicode characters are allowed
Public Function InputBoxEx(ByVal Prompt As String, Optional Title, Optional Default, Optional XPos, Optional YPos, Optional HelpFile, Optional Context) As String
    Dim s As String
    ' Check whether the parameters can be converted to String
    If Not IsEmpty(Title) And Not IsMissing(Title) Then s = CStr(Title)
    If Not IsEmpty(Default) And Not IsMissing(Default) Then s = CStr(Default)
    ' Store to the global variables to rewrite texts
    g_strResult = ""
    g_strPrompt = Prompt
    g_strTitle = Title
    g_strDefault = Default
    ' Start watching for window creation
    Call StartHook
    On Error Resume Next
    Call Err.Clear
    ' Call InputBox (a window will be created)
    Call InputBox("", , , XPos, YPos, HelpFile, Context)
    Dim Errno As Long
    Errno = Err.Number
    ' Stop watching (If VB error occurs, hook may not be unregistered, so call EndHook explicitly)
    Call EndHook
    On Error GoTo 0
    If Errno <> 0 Then
        Call Err.Raise(Errno)
    End If
    InputBoxEx = g_strResult
End Function

Usage:

Public Sub Test()
    Dim s As String
    s = InputBoxEx("メッセージだよ" + ChrW$(&HD83D&) + ChrW$(&HDE80&), "タイトル" + ChrW$(&HD83D&) + ChrW$(&HDE07&), "テキスト" + ChrW(&HD83D&) + ChrW(&HDE2E&) + ChrW(&H200D&) + ChrW(&HD83D&) + ChrW(&HDCA8&))
    Range("A1").Value = s
End Sub