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




Reply With Quote