The following code is an InpuBox that supports Unicode text (InpuBoxEx), the vb6 InpuBox only works with basic text, the dialog and all controls are created in ainsi version so the code is based on a MessageBoxW and a wide control edit was added to allow handling wide text and more exotic scripts.
Exemple..
Code:
Dim value As String
value = InputBoxEx("Unicode")
If StrPtr(value) <> 0 Then
MsgBox "ok: " & value
End If
Module: InputMod.bas
Code:
Option Explicit
'(code original)
'***************************************************************************************
'* inspired from INPUT BOX ETENDUE V0.4
' Auteur : Thierry GASPERMENT (Arkham46)
' Le code est libre pour toute utilisation
' Unicode version and style by Anycoder
Private Declare Function CreateWindowExW Lib "user32" (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, ByVal lpParam As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (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 GetFocus Lib "user32" () As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal Mode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal uObject As Long) 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 GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) 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 GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function BeginPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function OpenThemeData Lib "UxTheme.dll" (ByVal hWnd As Long, ByVal LPCWSTR As Long) As Long
Private Declare Function CloseThemeData Lib "UxTheme.dll" (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "UxTheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal pClipRect As Long) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpString As Long, ByVal nCount As Long, lpRect As RECT, ByVal uFormat As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByVal pRect As Long, ByVal Redraw As Long) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hWndFrom As Long, ByVal hWndTo As Long, lpPoints As Any, ByVal cPoints As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As Any) As Long
Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal wType As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(0 To 31) As Byte
End Type
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const GWL_WNDPROC = -4
Private Const GWL_STYLE = -16
Private Const GWL_ID = -12
Private Const BN_CLICKED = 0
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDEDIT = &H1324
Private Const IDSTATIC = &HFFFF&
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const WS_BORDER = &H800000
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WM_CREATE = &H1
Private Const WM_DESTROY = &H2
Private Const WM_SHOWWINDOW = &H18
Private Const WM_COMMAND = &H111
Private Const WM_GETTEXT = &HD
Private Const WM_SETFONT = &H30
Private Const WM_GETFONT = &H31
Private Const WM_PAINT = &HF
Private Const WM_MOUSEMOVE = &H200
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const DT_CALCRECT = &H400
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = 1
Private Const DT_VCENTER = 4
Private Hook As Long
Private Old_WinProc As Long
Private Ret As String
Private R1 As RECT, R2 As RECT
Private pDefault As String
Private Function hiword(ByVal lDWord As Long) As Integer
hiword = (CLng(lDWord) And &HFFFF0000) \ 65536
End Function
Private Function loword(ByVal lDWord As Long) As Integer
If lDWord And &H8000& Then
loword = CLng(lDWord) Or &HFFFF0000
Else
loword = CLng(lDWord) And &HFFFF&
End If
End Function
Private Function PtInRect(rc As RECT, ByVal x As Long, ByVal y As Long) As Long
With rc
If (x >= .Left) And (x <= .Right) Then
PtInRect = (y >= .Top) And (y <= .Bottom)
End If
End With
End Function
Private Function MakeRect(Left As Long, Top As Long, Width As Long, Height As Long) As RECT
MakeRect.Left = Left
MakeRect.Top = Top
MakeRect.Right = Left + Width
MakeRect.Bottom = Top + Height
End Function
Private Sub UpdateBtn(ByVal hWnd As Long, mouse() As Long, ByVal hdc As Long, ByVal ID As Long, ByVal aFocus As Long, R As RECT, ByVal ms As Long)
Dim hTheme As Long, stl As Long, Caption As String, st As Boolean
Dim child As Long
child = GetDlgItem(hWnd, ID)
st = child = aFocus
Caption = WinTxt(child)
stl = IIf(st, 5, 1)
If ms = 1 Then
stl = IIf(PtInRect(R, mouse(0), mouse(1)) <> 0, 3, stl)
Else
stl = IIf(PtInRect(R, mouse(0), mouse(1)) <> 0, 2, stl)
End If
hTheme = OpenThemeData(0, StrPtr("button"))
DrawThemeBackground hTheme, hdc, 1, stl, R, 0
CloseThemeData hTheme
DrawTextW hdc, StrPtr(Caption), Len(Caption), R, DT_SINGLELINE Or DT_VCENTER Or DT_CENTER
End Sub
Private Function HitTest(ByVal hWnd As Long, ByVal x As Long, ByVal y As Long) As Long
Static OldHitTest As Long
If PtInRect(R1, x, y) <> 0 Then
HitTest = IDOK
ElseIf PtInRect(R2, x, y) <> 0 Then
HitTest = IDCANCEL
End If
If HitTest <> OldHitTest Then
OldHitTest = HitTest
InvalidateRect hWnd, 0, 0
End If
End Function
Private Function WinTxt(ByVal hWnd As Long) As String
Dim Txt As String, nLen As Long
Txt = Space$(255)
nLen = SendMessage(hWnd, WM_GETTEXT, 255, StrPtr(Txt))
If nLen = 0 Then Exit Function
WinTxt = Left(Txt, nLen)
End Function
Private Function WinProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Static hfont As Long, OldHitTest As Long, LClient As RECT, TxtRect As RECT
Static msdown As Long
Dim lPaint As PAINTSTRUCT, dc As Long
Dim lNotify As Long, lID As Long
On Error Resume Next
Select Case Msg
Case WM_COMMAND
lNotify = hiword(wParam)
lID = loword(wParam)
If (lNotify = 7) Or (lNotify = 6) Then 'focus changed
InvalidateRect hWnd, 0, 0
WinProc = 1
Exit Function
End If
If (lID = IDOK) And (lNotify = BN_CLICKED) Then
Ret = WinTxt(GetDlgItem(hWnd, IDEDIT)) & ""
End If
Case WM_SHOWWINDOW
Dim Rcc As RECT, CancelBtn As Long, EditWidth As Long, btnW As Long, btnH As Long, newh As Long
If GetDlgItem(hWnd, IDEDIT) = 0 Then
CancelBtn = GetDlgItem(hWnd, IDCANCEL)
GetWindowRect CancelBtn, Rcc
btnH = Rcc.Bottom - Rcc.Top
btnW = Rcc.Right - Rcc.Left
btnW = btnH * 2.6
EditWidth = btnW * 3.5
dc = BeginPaint(CancelBtn, lPaint)
DrawTextW dc, StrPtr("Hp"), 2, Rcc, DT_CALCRECT
EndPaint CancelBtn, lPaint
Dim TxtHeight As Long
TxtHeight = (Rcc.Bottom - Rcc.Top) * 140 / 100
SetWindowLong GetDlgItem(hWnd, IDOK), GWL_STYLE, &H50034001
SetWindowLong GetDlgItem(hWnd, IDCANCEL), GWL_STYLE, &H50034001
SetWindowLong GetDlgItem(hWnd, IDSTATIC), GWL_STYLE, &H40020080
hfont = SendMessage(GetDlgItem(hWnd, IDOK), WM_GETFONT, 0, 0)
newh = CreateWindowExW(0, StrPtr("EDIT"), StrPtr(pDefault), &H50010080 Or WS_BORDER, 5, btnH * 1.5, EditWidth, TxtHeight, _
hWnd, 0, 0, 0)
SetWindowLong newh, GWL_ID, IDEDIT
SendMessage newh, WM_SETFONT, hfont, 0
R1 = MakeRect((EditWidth + 5 * 2) / 2 - btnW, btnH * 2.5, btnW, TxtHeight)
R2 = MakeRect((EditWidth + 5 * 2) / 2, btnH * 2.5, btnW, TxtHeight)
Dim Org As RECT, ClientR As RECT, DlgW As Long, DlgH As Long
GetWindowRect hWnd, Org
GetClientRect hWnd, ClientR
DlgW = EditWidth + 10 + Org.Right - (Org.Left + ClientR.Right)
DlgH = btnH * 4 + Org.Bottom - (Org.Top + ClientR.Bottom)
SetWindowPos hWnd, 0, 0, 0, DlgW, DlgH, SWP_NOMOVE
TxtRect = MakeRect(5, 5, EditWidth, btnH)
LClient = MakeRect(0, 0, DlgW, DlgH)
SetWindowPos GetDlgItem(hWnd, IDOK), 0, 5, -100, 0, 0, SWP_NOSIZE
SetWindowPos GetDlgItem(hWnd, IDCANCEL), 0, 5, -100, 0, 0, SWP_NOSIZE
SetFocus newh
msdown = 0
End If
Case WM_MOUSEMOVE
msdown = wParam
HitTest hWnd, loword(lParam), hiword(lParam)
Case WM_LBUTTONDOWN
msdown = 1
InvalidateRect hWnd, 0, 0
Case WM_LBUTTONUP
Dim hit As Long
msdown = 0
hit = HitTest(hWnd, loword(lParam), hiword(lParam))
If hit <> 0 Then
SendMessage hWnd, WM_COMMAND, hit, 0
End If
Case WM_PAINT
Dim hcrlt As Long, mouse(0 To 1) As Long, uMsg As String, hTheme As Long
If hfont <> 0 Then
dc = BeginPaint(hWnd, lPaint)
SelectObject dc, hfont
SetBkMode dc, 1
hTheme = OpenThemeData(0, StrPtr("listview"))
DrawThemeBackground hTheme, dc, 2, 2, LClient, 0
CloseThemeData hTheme
uMsg = WinTxt(GetDlgItem(hWnd, IDSTATIC))
DrawTextW dc, StrPtr(uMsg), Len(uMsg), TxtRect, DT_SINGLELINE Or DT_VCENTER
hcrlt = GetFocus
GetCursorPos mouse(0)
MapWindowPoints 0, hWnd, mouse(0), 1
UpdateBtn hWnd, mouse, dc, IDOK, hcrlt, R1, msdown
UpdateBtn hWnd, mouse, dc, IDCANCEL, hcrlt, R2, msdown
EndPaint hWnd, lPaint
WinProc = 1
Exit Function
End If
Case WM_DESTROY
Call SetWindowLong(hWnd, GWL_WNDPROC, Old_WinProc)
End Select
WinProc = CallWindowProc(Old_WinProc, hWnd, Msg, wParam, lParam)
End Function
Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lClass As String
On Error Resume Next
If nCode = HCBT_ACTIVATE Then
lClass = Space(255)
lClass = Left(lClass, GetClassName(wParam, ByVal lClass, 255))
If lClass = "#32770" Then
Call UnhookWindowsHookEx(Hook)
Old_WinProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf WinProc)
Hook = 0
Exit Function
End If
End If
CBTProc = CallNextHookEx(Hook, nCode, wParam, lParam)
End Function
Public Function InputBoxEx(ByVal Prompt As String, Optional ByVal Title As String, _
Optional ByVal Default As String, _
Optional ByVal XPos As Single = -1, Optional ByVal YPos As Single = -1, _
Optional ByVal HelpFile As String, _
Optional ByVal Context As Long) As String
Dim t As VbMsgBoxResult, tt As String
Hook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, 0, App.ThreadID)
Ret = vbNullString
pDefault = IIf(Default = "", "", Default)
tt = IIf(Title = "", App.Title, Title)
t = MessageBoxW(0, StrPtr(Prompt), StrPtr(tt), 1)
If Hook <> 0 Then ' if any
Call UnhookWindowsHookEx(Hook)
End If
If t = vbOK Then
InputBoxEx = Ret
End If
End Function
Dim value As String
value = InputBoxEx("Unicode")
If StrPtr(value) <> 0 Then
MsgBoxW "ok: " & value, , Me.Hwnd
End If
Code:
Public Sub MsgBoxW(Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal Hwnd As Long = 0)
Dim tt As String
tt = IIf(Title = "", App.Title, Title)
MessageBoxW Hwnd, StrPtr(Prompt), StrPtr(tt), vbSystemModal
End Sub
Yes, I agree with the idea to display Unicode text, it's necessary to use a component other than the native Msgox that handles Unicode,MessageBox is good choice especially since imported and fully compatible in params type with MsgBox.
Code:
Function MsgBoxW(ByVal Text As String, Optional ByVal Buttons As VbMsgBoxStyle = 0, Optional Title As String = "") As VbMsgBoxResult
Dim tt As String
tt = IIf(Title = "", App.Title, Title)
MsgBoxW = MessageBoxW(0, StrPtr(Text), StrPtr(tt), Buttons)
End Function
Small improvement for validation code,currently, when the Cancel button is focused and the Enter key is pressed, the validation is accepted, which is incorrect.
Code:
If (lID = IDOK) And (lNotify = BN_CLICKED) Then
If (GetFocus <> GetDlgItem(Hwnd, IDCANCEL)) Then 'added
Ret = WinTxt(GetDlgItem(Hwnd, IDEDIT)) & ""
End If
End If
Reply With Quote
