Wide string InputBox

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

---

good job.
a small addition.

Code:

---

    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, this is also a good example.

Quote:

---

good job.
a small addition.

---

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

---