Skip to content

Instantly share code, notes, and snippets.

@jet2jet
Created May 10, 2023 11:28
Show Gist options
  • Save jet2jet/dc28123215b0cc7894e7fbf56eb093b4 to your computer and use it in GitHub Desktop.
Save jet2jet/dc28123215b0cc7894e7fbf56eb093b4 to your computer and use it in GitHub Desktop.
Extended InputBox with full Unicode support for VB/VBA
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
@jet2jet
Copy link
Author

jet2jet commented May 10, 2023

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment