Page 1 of 2 12 LastLast
Results 1 to 40 of 41

Thread: VB6 - Original InputBox function reloaded with full Unicode support & new Edit Styles

  1. #1

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Thumbs up VB6 - Original InputBox function reloaded with full Unicode support & new Edit Styles

    Every time I've searched the internet on how to make the InputBox function support Unicode, the answers were to make your own InputBox using a form, a couple of buttons and a TextBox that supports Unicode. But this seems like a waste of a perfectly fine InputBox that you already have!

    The original InputBox from VB6 is actually a simple, run-of-the-mill Windows Dialog and as such it is perfectly capable of displaying Unicode characters on its own if it weren't for VB6 messing things up in the background. It turns out the solution is rather short and sweet so I've put together a small "cIB" class to wrap up the InputBox.

    As a bonus I've also included the possibility to use a "Password Char" to mask user input (same as a regular TextBox). Another improvement over the original InputBox is that now you can tell whether the user selected "OK" or "Cancel" without entering any text. Unicode characters can be used everywhere (in the Titlebar, Prompt and Edit box). Here's what it looks like:

    Name:  UnicodeInputBox.png
Views: 2206
Size:  36.5 KB

    UPDATE: The Unicode InputBox class has been enhanced with additional properties:

    • EnablePasswordChar - Can specify an optional character to mask the password with. If omitted then the standard asterisk will be displayed.
    • InputFontColor - Select a different text and/or background color for the "Input" text
    • OnlyNumericInput - Force the InputBox to accept only Numeric Input.
    • OnlyUppercase - Force the InputBox to display only "UPPERCASE" characters.
    • OnlyLowercase - Force the InputBox to display only "lowercase" characters.
    • MaxLength - Limit the InputBox text to the specified number of characters.
    • PromptFontColor - Select a different text and/or background color for the "Prompt" text
    • RequireInput - The user MUST type something in the InputBox but can still press "Cancel" if desired.

    Name:  UnicodeInputBoxUpdatedNew.png
Views: 240
Size:  9.3 KB

    UPDATE: In this update I have added the SetFont method which allows the possibility to select a font for the InputBox prompt. You can specify either the Font object of an existing control as a parameter or you can manually specify a font name, size and a combination of bold, italic and underline attributes. Optionally you can preserve the selected font between successive calls of the InputBox:

    Name:  UnicodeInputBoxFont.png
Views: 1721
Size:  15.7 KB

    UPDATE: The InpuBox size is calculated automatically in case your "Prompt" text doesn't fit in the default size. Some new features have been added as well:

    Now you can customize the text and/or background color of the "Prompt" and "Input" text fields (in addition to their font and size attributes). The edit box has been enhanced with a "placeholder text" (also known as "cue banner") that provides visual cues in case the user is required to type something in the InputBox.

    The placeholder text goes away automatically when you click in the edit box or begin to type. Also now you can make the InputBox mandatory by removing the possibility to cancel or close it until the user types something (this option is not recommended though as it makes for an overall poor user experience):

    Name:  UnicodeInputBoxRequireInput.png
Views: 232
Size:  16.6 KB

    The main "InputBoxW" property is marked as "Default" to keep the syntax as short as possible. The "cIB" class is also "Predeclared" so it can be used "as is" without declaring new instances:

    cIB.cls
    Code:
    Implements ISubclass
    
    Private sInputText As String, sPrompt As String, sTitle As String, wPasswordChar As Integer, m_bOkayClicked As Boolean, m_bEnablePasswordChar As Boolean, m_sCueBanner As String, _
            m_objFontStatic As IFont, m_objFontEdit As IFont, m_lMaxLength As Long, m_bOnlyNumericInput As Boolean, m_bOnlyUppercase As Boolean, m_bOnlyLowercase As Boolean, m_bPreserveFont As Boolean, _
            m_bPreserveStyle As Boolean, m_PromptFontColor, m_InputFontColor, m_PromptBackColor, m_InputBackColor, m_lInputBoxStyle As Long, m_bRequireInput As Boolean, m_bAllowCancel As Boolean, _
            hWndEdit As Long, hWndStatic As Long, wpInputBox As WINDOWPLACEMENT, wpStatic As WINDOWPLACEMENT, wpEdit As WINDOWPLACEMENT, hBrushStatic As Long, hBrushEdit As Long, _
            lAdjustStaticHeight As Long, lAdjustEditHeight As Long
    
    Public Property Get InputBoxW(Optional Prompt As String, Optional Title As String, Optional Default As String, Optional bInputCanceled As Boolean, Optional xPos, Optional yPos) As String
        If InputBoxHook(Me) Then ' Hook the DialogBoxParamA API function used to create the InputBox Dialog, subclass it and initialize the parameters
            sPrompt = Prompt: sTitle = Title: sInputText = Default
            InputBox sPrompt, , , xPos, yPos ' Display the classic VB6 InputBox Dialog
            bInputCanceled = Not m_bOkayClicked ' Return user's choice
            If m_bOkayClicked Then InputBoxW = sInputText
            If Not m_bPreserveFont Then Set m_objFontStatic = Nothing: Set m_objFontEdit = Nothing
            If Not m_bPreserveStyle Then m_lInputBoxStyle = 0
        End If
    End Property
    
    Public Property Let InputBoxW(Optional Prompt As String, Optional Title As String, Optional Default As String, Optional bInputCanceled As Boolean, Optional xPos, Optional yPos, InputBoxW As String)
        ' Property Let doesn't do anything but it's required to mark this property as "Default" for our class.
    End Property
    
    Friend Property Get EnablePasswordChar(Optional PasswordChar As String) As Boolean
        PasswordChar = ChrW$(wPasswordChar): EnablePasswordChar = m_bEnablePasswordChar
    End Property
    
    Friend Property Let EnablePasswordChar(Optional PasswordChar As String = "*", bEnablePasswordChar As Boolean)
        m_bEnablePasswordChar = bEnablePasswordChar
        If m_bEnablePasswordChar Then wPasswordChar = AscW(PasswordChar) Else wPasswordChar = 0
    End Property
    
    Friend Property Get InputFontColor(Optional clrBackColor As ColorConstants) As ColorConstants
        clrBackColor = m_InputBackColor: InputFontColor = m_InputFontColor
    End Property
    
    Friend Property Let InputFontColor(Optional clrBackColor As ColorConstants = -1, clrFontColor As ColorConstants)
        If clrBackColor >= 0 Then m_InputBackColor = clrBackColor Else m_InputBackColor = Empty
        m_InputFontColor = clrFontColor
    End Property
    
    Friend Property Get PromptFontColor(Optional clrBackColor As ColorConstants) As ColorConstants
        clrBackColor = m_PromptBackColor: PromptFontColor = m_PromptFontColor
    End Property
    
    Friend Property Let PromptFontColor(Optional clrBackColor As ColorConstants = -1, clrFontColor As ColorConstants)
        If clrBackColor >= 0 Then m_PromptBackColor = clrBackColor Else m_PromptBackColor = Empty
        m_PromptFontColor = clrFontColor
    End Property
    
    Friend Property Get MaxLength() As Long
        MaxLength = m_lMaxLength
    End Property
    
    Friend Property Let MaxLength(lMaxLength As Long)
        m_lMaxLength = lMaxLength
    End Property
    
    Friend Property Get OnlyNumericInput(Optional bPreserveStyle As Boolean) As Boolean
         bPreserveStyle = m_bPreserveStyle: OnlyNumericInput = m_bOnlyNumericInput
    End Property
    
    Friend Property Let OnlyNumericInput(Optional bPreserveStyle As Boolean = True, bOnlyNumericInput As Boolean)
        m_bPreserveStyle = bPreserveStyle: m_bOnlyNumericInput = bOnlyNumericInput
        If m_bOnlyNumericInput Then m_lInputBoxStyle = m_lInputBoxStyle Or ES_NUMBER Else m_lInputBoxStyle = m_lInputBoxStyle And Not ES_NUMBER
    End Property
    
    Friend Property Get OnlyUppercase(Optional bPreserveStyle As Boolean) As Boolean
        bPreserveStyle = m_bPreserveStyle: OnlyUppercase = m_bOnlyUppercase
    End Property
    
    Friend Property Let OnlyUppercase(Optional bPreserveStyle As Boolean = True, bOnlyUppercase As Boolean)
        m_bPreserveStyle = bPreserveStyle: m_bOnlyUppercase = bOnlyUppercase
        If m_bOnlyUppercase Then m_lInputBoxStyle = m_lInputBoxStyle Or ES_UPPERCASE Else m_lInputBoxStyle = m_lInputBoxStyle And Not ES_UPPERCASE
    End Property
    
    Friend Property Get OnlyLowercase(Optional bPreserveStyle As Boolean) As Boolean
        bPreserveStyle = m_bPreserveStyle: OnlyLowercase = m_bOnlyLowercase
    End Property
    
    Friend Property Let OnlyLowercase(Optional bPreserveStyle As Boolean = True, bOnlyLowercase As Boolean)
        m_bPreserveStyle = bPreserveStyle: m_bOnlyLowercase = bOnlyLowercase
        If m_bOnlyLowercase Then m_lInputBoxStyle = m_lInputBoxStyle Or ES_LOWERCASE Else m_lInputBoxStyle = m_lInputBoxStyle And Not ES_LOWERCASE
    End Property
    
    Friend Property Get RequireInput(Optional sCueBanner As String, Optional bAllowCancel As Boolean) As Boolean
        sCueBanner = m_sCueBanner: bAllowCancel = m_bAllowCancel: RequireInput = m_bRequireInput
    End Property
    
    Friend Property Let RequireInput(Optional sCueBanner As String, Optional bAllowCancel As Boolean = True, bRequireInput As Boolean)
        m_bAllowCancel = bAllowCancel: m_bRequireInput = bRequireInput
        If m_bRequireInput Then m_sCueBanner = sCueBanner Else m_sCueBanner = vbNullString
    End Property
    
    Friend Sub SetFont(Optional eSelectFont As SELECT_FONTS = ePromptFont, Optional ByVal objFont As IFont, Optional sFontFace As String, Optional cyFontSize As Currency, Optional CFS_FONTSTYLE As CFS_FONTSTYLES = CFS_FONTSTYLENONE, Optional bPreserveFont As Boolean = True)
    Dim fdFontDesc As FONTDESC, IID_FONT(0 To 1) As Currency
        m_bPreserveFont = bPreserveFont
        If objFont Is Nothing Then
            With fdFontDesc
                .cbSizeofstruct = LenB(fdFontDesc): .lpstrName = StrPtr(sFontFace): .cySize = cyFontSize
                If (CFS_FONTSTYLE And CFE_BOLD) = CFE_BOLD Then .sWeight = FW_BOLD Else .sWeight = FW_REGULAR
                .fItalic = (CFS_FONTSTYLE And CFE_ITALIC) = CFE_ITALIC: .fUnderline = (CFS_FONTSTYLE And CFE_UNDERLINE) = CFE_UNDERLINE
            End With
            IID_FONT(1) = IID_IUnknown1: OleCreateFontIndirect VarPtr(fdFontDesc), VarPtr(IID_FONT(0)), objFont
        End If
        Select Case eSelectFont
            Case ePromptFont: Set m_objFontStatic = objFont
            Case eInputFont: Set m_objFontEdit = objFont
        End Select
    End Sub
    
    Private Sub Class_Initialize()
        wpInputBox.Length = LenB(wpInputBox): wpStatic.Length = LenB(wpStatic): wpEdit.Length = LenB(wpEdit)
    End Sub
    
    Private Function GetTextHeight(hWnd As Long, hDC As Long) As Long
    Dim rcText As RECT, lpSize As SIZEL, sText As String, lOldFont As Long
        Select Case hWnd
            Case hWndStatic
                If Len(sPrompt) Then sText = sPrompt Else sText = Space$(1)
                rcText = wpStatic.rcNormalPosition
                DrawTextW hDC, StrPtr(sText), Len(sText), VarPtr(rcText), DT_CALCRECT Or DT_EDITCONTROL Or DT_WORDBREAK Or DT_NOPREFIX ' Calculate the height of the "Prompt" text
                GetTextHeight = rcText.Bottom - rcText.Top
            Case hWndEdit
                If Len(sInputText) Then sText = sInputText Else sText = Space$(1)
                lOldFont = SelectObject(hDC, SendMessageW(hWnd, WM_GETFONT, 0&, 0&))
                GetTextExtentPoint32W hDC, StrPtr(sText), Len(sText), VarPtr(lpSize) ' Calculate the height of the "Input" text
                GetTextHeight = lpSize.cy: SelectObject hDC, lOldFont
        End Select
    End Function
    
    Private Function ISubclass_WndProc(hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, dwRefData As Long, bDiscardMessage As Boolean) As Long
    Dim lTextLen As Long, rcEdit As RECT
        Select Case uMsg
            Case WM_INITDIALOG
                hWndStatic = GetDlgItem(hWnd, ID_STATIC): hWndEdit = GetDlgItem(hWnd, ID_EDIT)
                If m_bRequireInput And Not m_bAllowCancel Then ShowWindow GetDlgItem(hWnd, IDCANCEL), SW_HIDE: SetWindowLongW hWnd, GWL_STYLE, GetWindowLongW(hWnd, GWL_STYLE) And Not WS_SYSMENU
                If m_lInputBoxStyle Then SetWindowLongW hWndEdit, GWL_STYLE, GetWindowLongW(hWndEdit, GWL_STYLE) Or m_lInputBoxStyle
            Case WM_SHOWWINDOW ' The InputBox Dialog is about to be displayed and ready to be modified
                GetWindowPlacement hWnd, VarPtr(wpInputBox): GetWindowPlacement hWndStatic, VarPtr(wpStatic): GetWindowPlacement hWndEdit, VarPtr(wpEdit)
                If Not (m_objFontStatic Is Nothing) Then
                    lAdjustStaticHeight = wpStatic.rcNormalPosition.Bottom - wpStatic.rcNormalPosition.Top: SendMessageW hWndStatic, WM_SETFONT, m_objFontStatic.hFont, APITRUE
                End If
                If Not (m_objFontEdit Is Nothing) Then
                    GetClientRect hWndEdit, VarPtr(rcEdit): lAdjustEditHeight = rcEdit.Bottom - rcEdit.Top: SendMessageW hWndEdit, WM_SETFONT, m_objFontEdit.hFont, APITRUE
                End If
                If Len(sTitle) Then SetWindowTextW hWnd, StrPtr(sTitle) ' Set the titlebar text
                If Len(sPrompt) Then SendMessageW hWndStatic, WM_SETTEXT, 0&, StrPtr(sPrompt) ' Set the "Prompt" text
                If wPasswordChar Then SendMessageW hWndEdit, EM_SETPASSWORDCHAR, CLng(wPasswordChar), 0& ' Optional password char to mask user input
                If Len(m_sCueBanner) Then SendMessageW hWndEdit, EM_SETCUEBANNER, APITRUE, StrPtr(m_sCueBanner) ' Optional cue banner to explain why input is required
                If m_lMaxLength > 0 Then SendMessageW hWndEdit, EM_SETLIMITTEXT, m_lMaxLength, 0&: sInputText = Left$(sInputText, m_lMaxLength)
                If Len(sInputText) Then SendMessageW hWndEdit, WM_SETTEXT, 0&, StrPtr(sInputText): SendMessageW hWndEdit, EM_SETSEL, 0&, -1& ' Set and select "Default" text
            Case WM_COMMAND
                Select Case wParam
                    Case IDOK ' User clicked the "OK" button or pressed Enter to close the InputBox Dialog
                        lTextLen = SendMessageW(hWndEdit, WM_GETTEXTLENGTH, 0&, 0&) ' Get the text length
                        sInputText = String$(lTextLen, vbNullChar)
                        lTextLen = GetWindowTextW(hWndEdit, StrPtr(sInputText), lTextLen + 1) ' Read the actual text entered by the user
                        If lTextLen Then
                            m_bOkayClicked = True
                        Else
                            If m_bRequireInput Then
                                m_bOkayClicked = False: bDiscardMessage = True ' If input is required then the user must type something in the InputBox Dialog but can still press Cancel if desired
                            Else
                                m_bOkayClicked = True
                            End If
                        End If
                    Case IDCANCEL
                        m_bOkayClicked = False
                        If m_bRequireInput And Not m_bAllowCancel Then bDiscardMessage = True ' The user cannot cancel the InputBox when this option is active (not recommended, poor user experience)
                End Select
            Case WM_CTLCOLORSTATIC
                If lAdjustStaticHeight > 0 Then
                    lAdjustStaticHeight = GetTextHeight(hWndStatic, wParam) - lAdjustStaticHeight
                    If lAdjustStaticHeight > 0 Then ' We need to enlarge the InputBox window to accommodate a larger size for the "Prompt" text
                        With wpInputBox.rcNormalPosition
                            .Bottom = .Bottom + lAdjustStaticHeight
                            SetWindowPos hWnd, 0, 0, 0, .Right - .Left, .Bottom - .Top, SWP_NOMOVE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
                        End With
                        With wpStatic.rcNormalPosition
                            SetWindowPos hWndStatic, 0, 0, 0, .Right - .Left, .Bottom - .Top + lAdjustStaticHeight, SWP_NOMOVE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
                        End With
                        With wpEdit.rcNormalPosition
                            SetWindowPos hWndEdit, 0, .Left, .Top + lAdjustStaticHeight, 0, 0, SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
                        End With
                        lAdjustStaticHeight = 0
                    End If
                End If
                If Not IsEmpty(m_PromptFontColor) Or Not IsEmpty(m_PromptBackColor) Then
                    SetBkMode wParam, TRANSPARENT: SetTextColor wParam, m_PromptFontColor ' Set the text color of the "Prompt" text
                    If hBrushStatic = 0 Then hBrushStatic = CreateSolidBrush(IIf(IsEmpty(m_PromptBackColor), GetSysColor(COLOR_BTNFACE), m_PromptBackColor)) ' Set the background color of the "Prompt" text
                    bDiscardMessage = True: ISubclass_WndProc = hBrushStatic
                End If
            Case WM_CTLCOLOREDIT
                If lAdjustEditHeight > 0 Then
                    lAdjustEditHeight = GetTextHeight(hWndEdit, wParam) - lAdjustEditHeight
                    If lAdjustEditHeight > 0 Then ' We need to enlarge the "Edit" control to accommodate a larger font size for the "Input" text
                        With wpInputBox.rcNormalPosition
                            SetWindowPos hWnd, 0, 0, 0, .Right - .Left, .Bottom - .Top + lAdjustEditHeight + 3, SWP_NOMOVE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
                        End With
                        With wpEdit.rcNormalPosition
                            SetWindowPos hWndEdit, 0, 0, 0, .Right - .Left, .Bottom - .Top + lAdjustEditHeight + 3, SWP_NOMOVE Or SWP_NOOWNERZORDER Or SWP_NOZORDER
                        End With
                        lAdjustEditHeight = 0
                    End If
                End If
                If Not IsEmpty(m_InputFontColor) Or Not IsEmpty(m_InputBackColor) Then
                    SetBkMode wParam, TRANSPARENT: SetTextColor wParam, m_InputFontColor ' Set the text color of the "Input" text
                    If hBrushEdit = 0 Then hBrushEdit = CreateSolidBrush(IIf(IsEmpty(m_InputBackColor), vbWhite, m_InputBackColor)) ' Set the background color of the "Input" text
                    bDiscardMessage = True: ISubclass_WndProc = hBrushEdit
                End If
            Case WM_DESTROY
                If hBrushStatic Then If DeleteObject(hBrushStatic) Then hBrushStatic = 0
                If hBrushEdit Then If DeleteObject(hBrushEdit) Then hBrushEdit = 0
                If lAdjustStaticHeight Then lAdjustStaticHeight = 0: If lAdjustEditHeight Then lAdjustEditHeight = 0
        End Select
    End Function
    Basically the whole idea is to hook the "DialogBoxParamA" API function used to create the InputBox Dialog and then subclass it:

    mdlInputBox.bas
    Code:
    Private Const WM_NCDESTROY As Long = &H82
    
    Private Declare Sub PutMem4 Lib "msvbvm60" (Ptr As Any, ByVal NewVal As Long)
    Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (ByVal dstObject As Long, ByVal srcObject As Long) As Long
    Private Declare Function SetWindowSubclass Lib "comctl32" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
    Private Declare Function GetWindowSubclass Lib "comctl32" Alias "#411" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, pdwRefData As Long) As Long
    Private Declare Function RemoveWindowSubclass Lib "comctl32" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
    Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As Long) As Long
    Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByVal lpBuffer As Long, ByVal nSize As Long, lpNumberOfBytesRead As Long) As Long
    Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByVal lpBuffer As Long, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
    Private Declare Function CallWindowProcW Lib "user32" (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 DialogBoxParamW Lib "user32" (ByVal hInstance As Long, ByVal lpTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
    Public Declare Function OleTranslateColor Lib "oleaut32" (ByVal Color As Long, ByVal hPal As Long, colorRef As Long) As Long
    Public Declare Function GetWindowLongW Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function SetWindowLongW Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    
    Private m_lSubclassInputBox As Long, hWndInputBox As Long, lpDialogBoxParamA As Long, lpOriginalDlgProc As Long, baOriginalDialogBoxParamA(0 To 5) As Byte, baTrampoline(0 To 5) As Byte
    
    Public Function InputBoxHook(SubclassInputBox As ISubclass) As Boolean
        If lpDialogBoxParamA = 0 Then
            lpDialogBoxParamA = GetProcAddress(GetModuleHandleW(StrPtr("user32")), "DialogBoxParamA") ' Get the address of the "DialogBoxParamA" function
            ReadProcessMemory -1&, lpDialogBoxParamA, VarPtr(baOriginalDialogBoxParamA(0)), 6&, 0& ' Save the first 6 bytes (the size of the trampoline) to be restored later
            baTrampoline(0) = &H68 ' push
            PutMem4 baTrampoline(1), AddressOf HookedDialogBoxParamA ' Set up the trampoline jump to our custom "HookedDialogBoxParamA" function
            baTrampoline(5) = &HC3 ' ret
        End If
        m_lSubclassInputBox = ObjPtr(SubclassInputBox): hWndInputBox = 0 ' Save a reference to our cIB object for subclassing and reset the InputBox window handle
        InputBoxHook = WriteProcessMemory(-1&, lpDialogBoxParamA, VarPtr(baTrampoline(0)), 6&, 0&) ' Now the InputBox function will call our custom "HookedDialogBoxParamA" function instead
    End Function
    
    Private Function HookedDialogBoxParamA(ByVal hInstance As Long, ByVal lpTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Long
        lpOriginalDlgProc = lpDialogFunc ' Save the address of the original DLGPROC callback function (we need to call this later)
        WriteProcessMemory -1&, lpDialogBoxParamA, VarPtr(baOriginalDialogBoxParamA(0)), 6&, 0& ' Restore the original "DialogBoxParamA" API function
        HookedDialogBoxParamA = DialogBoxParamW(hInstance, lpTemplateName, hWndParent, AddressOf DlgProc, dwInitParam) ' Call "DialogBoxParamW" using our custom "DlgProc" instead
    End Function
    
    Private Function DlgProc(ByVal hWndDlg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        If hWndInputBox = 0 Then hWndInputBox = hWndDlg: SubclassWnd hWndInputBox, m_lSubclassInputBox ' This is the hWnd of the InputBox Dialog window so we can finally subclass it!
        DlgProc = CallWindowProcW(lpOriginalDlgProc, hWndDlg, uMsg, wParam, lParam) ' Call the original DLGPROC callback function to process the rest of messages
    End Function
    
    Private Function SubclassWnd(hWnd As Long, vSubclass As Variant, Optional dwRefData As Long, Optional bUpdateRefData As Boolean) As Boolean
    Dim Subclass As ISubclass, uIdSubclass As Long, lOldRefData As Long
        If IsObject(vSubclass) Then Set Subclass = vSubclass Else vbaObjSetAddref VarPtr(Subclass), vSubclass
        uIdSubclass = ObjPtr(Subclass)
        If Not IsWndSubclassed(hWnd, uIdSubclass, lOldRefData) Then
            SubclassWnd = SetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
        Else
            If bUpdateRefData Then If lOldRefData <> dwRefData Then SubclassWnd = SetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
        End If
    End Function
    
    Private Function UnSubclassWnd(hWnd As Long, uIdSubclass As Long) As Boolean
        If IsWndSubclassed(hWnd, uIdSubclass) Then UnSubclassWnd = RemoveWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass)
    End Function
    
    Private Function IsWndSubclassed(hWnd As Long, uIdSubclass As Long, Optional dwRefData As Long) As Boolean
        IsWndSubclassed = GetWindowSubclass(hWnd, AddressOf WndProc, uIdSubclass, dwRefData)
    End Function
    
    Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Subclass As ISubclass, ByVal dwRefData As Long) As Long
    Dim bDiscardMessage As Boolean
        Select Case uMsg
            Case WM_NCDESTROY ' Remove subclassing as the window is about to be destroyed
                UnSubclassWnd hWnd, ObjPtr(Subclass)
            Case Else
                WndProc = Subclass.WndProc(hWnd, uMsg, wParam, lParam, dwRefData, bDiscardMessage)
        End Select
        If Not bDiscardMessage Then WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
    End Function
    And of course the ubiquitous ISubclass stub (to use with Implements):

    ISubclass.cls
    Code:
    Public Function WndProc(hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, dwRefData As Long, bDiscardMessage As Boolean) As Long
    
    End Function
    That's all there is to it. Here's a small demo program with the InputBox showing some Japanese haikus as well as the password char in action:

    UnicodeInputBoxNew.zip (Updated)

  2. #2
    Hyperactive Member
    Join Date
    Jun 2016
    Location
    España
    Posts
    506

    Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    good job, work fine

  3. #3
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    Your work is very great, applaud. Give VB6 life, help it more perfect and easier to use.

  4. #4
    Hyperactive Member
    Join Date
    Jun 2016
    Location
    España
    Posts
    506

    Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    a question.
    I try to move your code to a dll.
    But it only works if I put the resource file in the main program and not in the dll.
    It is not possible for the dll to use its own resource file.
    Regards, thanks

  5. #5

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    Mate the resource file contains only the manifest for the modern theme, otherwise the interface would look like it came straight from the last century. Only executables need manifests, you don't need it for the dll!

  6. #6

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Cool Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    UPDATE: The Unicode InputBox class has been enhanced with additional properties:

    • EnablePasswordChar - Can specify an optional character to mask the password with. If omitted then the standard Windows Password Character will be displayed (NOT an asterisk)!
    • OnlyNumericInput - Force the InputBox to accept only Numeric Input.
    • OnlyUppercase - Force the InputBox to display only "UPPERCASE" characters.
    • OnlyLowercase - Force the InputBox to display only "lowercase" characters.
    • MaxLength - Limit the InputBox text to the specified number of characters.
    • RequireInput - The user MUST type something in the InputBox but can still press "Cancel" if desired.

    Name:  UnicodeInputBoxUpdated.png
Views: 1518
Size:  8.4 KB
    Last edited by VanGoghGaming; Aug 4th, 2023 at 08:55 PM.

  7. #7

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Thumbs up Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    UPDATE: In this update I have added the SetFont method which allows the possibility to select a font for the InputBox prompt. You can specify either the Font object of an existing control as a parameter or you can manually specify a font name, size and a combination of bold, italic and underline attributes. Optionally you can preserve the selected font between successive calls of the InputBox:

    Name:  UnicodeInputBoxFont.png
Views: 1721
Size:  15.7 KB

  8. #8

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Thumbs up Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    This update includes two new properties and one new method for the InputBox:

    • MaxLength - Limit the InputBox text to the specified number of characters.
    • RequireInput - The InputBox cannot be empty, the user MUST type something in the InputBox but can still press "Cancel" if desired.


    Name:  UnicodeInputBoxUpdated.png
Views: 1509
Size:  8.4 KB

    The AdjustHeight method allows you to enlarge the InputBox height by a specified percentage in case your "Prompt" text doesn't fit in the default InputBox size. In this screenshot the InputBox height has been increased by 25% and now all text fits nicely:

    Name:  UnicodeInputBoxAdjustHeight.png
Views: 1489
Size:  10.9 KB

    As usual you can download this latest update from the first post above.

  9. #9
    Addicted Member
    Join Date
    Feb 2022
    Posts
    167

    Re: VB6 - Original InputBox function reloaded with full Unicode and Password Char sup

    Quote Originally Posted by VanGoghGaming View Post
    As usual you can download this latest update from the first post above.
    Great work! However, it shows the haiku as ??? strings in the IDE, but perfect Japanese when running compiled. Am I missing something?
    Cheers

  10. #10

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Wink Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    It works in the IDE as well, just don't use breakpoints to stop the execution. That will prevent the InputBox from being hooked and subclassed and so it won't be able to display proper Unicode characters.

  11. #11
    PowerPoster yereverluvinuncleber's Avatar
    Join Date
    Feb 2014
    Location
    Norfolk UK (inbred)
    Posts
    2,235

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I will attempt to use this inputBox improvement. I don't use it often and when I have done so, I have generally ended up rolling my own (and done a fairly poor job of it), so thankyou for this.
    https://github.com/yereverluvinunclebert

    Skillset: VMS,DOS,Windows Sysadmin from 1985, fault-tolerance, VaxCluster, Alpha,Sparc. DCL,QB,VBDOS- VB6,.NET, PHP,NODE.JS, Graphic Design, Project Manager, CMS, Quad Electronics. classic cars & m'bikes. Artist in water & oils. Historian.

    By the power invested in me, all the threads I start are battle free zones - no arguing about the benefits of VB6 over .NET here please. Happiness must reign.

  12. #12
    Addicted Member
    Join Date
    Feb 2022
    Posts
    167

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Quote Originally Posted by VanGoghGaming View Post
    It works in the IDE as well, just don't use breakpoints to stop the execution. That will prevent the InputBox from being hooked and subclassed and so it won't be able to display proper Unicode characters.
    I don't have any breakpoints, so it must be one of my add-ins preventing it. Cheers

  13. #13
    Addicted Member
    Join Date
    Jul 2021
    Posts
    193

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I second taishan's claim - not working in IDE, showing the ???.
    When I compile and run I get a strange message from windows: "The application has failed to start because its side by side configuration is incorrect..."
    This is just too much for me. I give up.

  14. #14

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Cool Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    That's a very strange error indeed, just remove the external manifest since it's already included in the resource file. Probably your Windows is set up to prefer external manifests.

    Anyway I've uploaded a new version that should work in the IDE for you as well (although it always has for the majority of users so far). I could only guess the problem was with reading the Unicode text from file.

  15. #15
    PowerPoster yereverluvinuncleber's Avatar
    Join Date
    Feb 2014
    Location
    Norfolk UK (inbred)
    Posts
    2,235

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Quote Originally Posted by Dry Bone View Post
    I second taishan's claim - not working in IDE, showing the ???.
    When I compile and run I get a strange message from windows: "The application has failed to start because its side by side configuration is incorrect..."
    This is just too much for me. I give up.
    Works perfectly for me on Win10, I run with UAC off if that helps.

    FYI - V.G you have bundled a binary in with that zipfile which I believe a forum rule disallows. Best to remove it and let everyone compile themselves.
    https://github.com/yereverluvinunclebert

    Skillset: VMS,DOS,Windows Sysadmin from 1985, fault-tolerance, VaxCluster, Alpha,Sparc. DCL,QB,VBDOS- VB6,.NET, PHP,NODE.JS, Graphic Design, Project Manager, CMS, Quad Electronics. classic cars & m'bikes. Artist in water & oils. Historian.

    By the power invested in me, all the threads I start are battle free zones - no arguing about the benefits of VB6 over .NET here please. Happiness must reign.

  16. #16

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Cool Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    There is no binary, you've mistaken "InputBoxTest.exe.manifest" which is a text file.

  17. #17
    PowerPoster yereverluvinuncleber's Avatar
    Join Date
    Feb 2014
    Location
    Norfolk UK (inbred)
    Posts
    2,235

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I swear I saw a binary, I thought I immediately recompiled and overwrote it. I do know what an external manifest looks like, so I shouldn't have mistaken that. Must have been a glitch in my own personal matrix.

    Anyway, my real point is that it all works for me! Very well indeed.
    https://github.com/yereverluvinunclebert

    Skillset: VMS,DOS,Windows Sysadmin from 1985, fault-tolerance, VaxCluster, Alpha,Sparc. DCL,QB,VBDOS- VB6,.NET, PHP,NODE.JS, Graphic Design, Project Manager, CMS, Quad Electronics. classic cars & m'bikes. Artist in water & oils. Historian.

    By the power invested in me, all the threads I start are battle free zones - no arguing about the benefits of VB6 over .NET here please. Happiness must reign.

  18. #18
    Addicted Member
    Join Date
    Jul 2021
    Posts
    193

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I can run the compiled version now. Still getting the "???". It's not encoding related. The strings are ok, just won't show on dialog.
    The title is unicode alright, but the message is all "???", and the Textbox is also "???" and won't accept unicode characters!
    What is going on?

  19. #19
    Addicted Member
    Join Date
    Jul 2021
    Posts
    193

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Hey, look at this cool method for unicode InputBox:
    Code:
    Public Function InputBoxW(Prompt, Title, Default) As String
    Dim sc
    Dim s
    Set sc = CreateObject("msscriptcontrol.scriptcontrol")
    sc.language = "vbscript"
    s = sc.Eval("InputBox(""" & Prompt & """,""" & Title & """,""" & Default & """)")
    If IsEmpty(s) Then s = vbNullString Else If Len(s) = 0 Then s = ""
    InputBoxW = s
    End Function
    What say ye?

  20. #20

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Question Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    No idea what's going on mate, especially since you say the InputBox title is showing Unicode characters correctly. That means the InputBox is correctly subclassed and is receiving messages so I don't know why the "EditBox" isn't responding well to the "WM_SETTEXT" message for you.

    If you manage to sort it out I'd be interested to know what was the cause of this strange issue for you.

  21. #21
    Addicted Member
    Join Date
    Feb 2022
    Posts
    167

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Hey BroVanGogh, it works perfectly now, inIDE and Exe. Excellent!
    Can we hack the size of the font? I've been trying to push everything up to Segoe UI 11pt.
    Cheers

  22. #22

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Wink Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Yeah there's a "SetFont" method to use whatever font and size you want, this is mentioned above as well. I don't know what's all the rage with this Segoe font. I prefer the "Microsoft Sans Serif" font which is the TrueType successor of the good ol' tried and tested "MS Sans Serif" bitmap font.

  23. #23
    Addicted Member
    Join Date
    Feb 2022
    Posts
    167

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Great news on the font sizing! For my eyes Segoe looks beautiful with the Asian ideograms, and those from Arabic and Hebrew to Thai and Hindi. It is just a great UI font, but I will take another look at Sans Serif. I guess you'll have to make another project for the good old message box. Elroy and Niya broke ground with a great start, prompting dil to write the funniest response I've ever read on the forums.Cheers
    Last edited by taishan; Nov 12th, 2023 at 06:36 AM.

  24. #24

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Wink Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    What's even funnier is that he's not wrong at all!

  25. #25
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Quote Originally Posted by Dry Bone View Post
    I second taishan's claim - not working in IDE, showing the ???.
    When I compile and run I get a strange message from windows: "The application has failed to start because its side by side configuration is incorrect..."
    This is just too much for me. I give up.
    You most likely needed to install a manifest for yourself VB6.EXE

  26. #26
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    In fact, there is a way to call the native InputBox from the library msvbvm60.dll directly using the DialogBoxParamW function.

  27. #27
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St


  28. #28
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    My function works without manifests.

  29. #29

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Thumbs up Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Thanks to user "HackerVlad" above, I have fixed the issue encountered by some users where the InputBox would not display Unicode characters in the absence of a theme manifest. Also I have replaced the method of finding the InputBox Dialog, instead of installing a CBT hook with "SetWindowsHookEx" now the program employs a basic "trampoline" hook on the "DialogBoxParamA" API function used to create the InputBox. The demo project has been updated in the first post above.

  30. #30
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I also want to point out the advantages of my function:

    1. Does not require manifests
    2. There are no complicated hooks
    3. No need to use sophisticated subclassing technology
    4. There is no need for any trampolines and redirects
    5. The function is written very clearly, almost like in the original source code from Microsoft
    6. The window alignment is exactly the same as in the original InputBox as in Microsoft
    7. An additional feature has been added to align the window to the center of the working area of the screen

    Code:
    Option Explicit
    '////////////////////////////////////////////
    '// Module for calling Unicode InputBox    //
    '// Copyright (c) 2024-02-01 by HackerVlad //
    '// e-mail: vladislavpeshkov@yandex.ru     //
    '// 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

  31. #31
    Super Moderator Shaggy Hiker's Avatar
    Join Date
    Aug 2002
    Location
    Idaho
    Posts
    38,988

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    So why not create your own CodeBank thread rather than just posting into this one. The thread back in the Q&A section is a good place to debate the merits of different approaches, but the CodeBank is not. This area is for posting working snippets and questions regarding those working snippets. Since your reply is neither, I was tempted to do something other than just replying. One option would be to split it out into its own thread, but you should do that, not me, as that first post would be kind of important. The other option was to remove the post along with replying as I have (minus this part, as that would be way too self-referential), but I decided not to, as it would make this reply quite weird.
    My usual boring signature: Nothing

  32. #32
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I'm new to this forum. Forgive me.

  33. #33

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Thumbs up Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    No worries, the purpose of this thread is focused only on the original VB6 "InputBox" function and enhancing it with additional edit styles and new features. Speaking of which, I have just released a new update (which can be downloaded from the first post above as usual).

    The size of the InputBox is now calculated automatically in case the "Prompt" text is too big to fit in the original size. There is no longer a need to approximate the height increase by a percentage as it will be calculated on the fly for the best fit!

    Also now you can use the FontColor property to customize the color of the "Prompt" text (in addition to its font and size attributes). The edit box has been enhanced with a "placeholder text" (also known as "cue banner") that provides visual cues in case the user is required to type something in the InputBox.

    The placeholder text goes away automatically when you click in the edit box or begin to type. Also now you can make the InputBox mandatory by removing the possibility to cancel or close it until the user types something (this option is not recommended though as it makes for a poor user experience overall):

    Name:  UnicodeInputBoxRequireInput.png
Views: 229
Size:  16.6 KB

  34. #34
    Addicted Member
    Join Date
    Feb 2022
    Posts
    167

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Excellent work, BroVanGogh! I think you've conquered this exercise. You've become the Unicode master for those who want to stay within the confines of VB common controls! Cheers

  35. #35
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    VanGoghGaming great job! I like that you added the ability to change the color of the label text! But forum users still want to be able to change the text color and the background color of the text field. https://www.vbforums.com/showthread....=1#post5631388

  36. #36

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Cool Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Quote Originally Posted by HackerVlad View Post
    But forum users still want to be able to change the text color and the background color of the text field.
    Sometimes, forum users want the most unreasonable of things! You can change the background colors although it doesn't look great in my opinion:

    Name:  UnicodeInputBoxColor.png
Views: 214
Size:  6.1 KB

    We need to handle the "WM_CTLCOLORSTATIC" and "WM_CTLCOLOREDIT" messages and instead of returning a system brush with the background color we create a new brush with whatever background color we want and return that instead. Unlike the system brush, this new brush will have to be deleted when we're done with it:

    Code:
            Case WM_CTLCOLORSTATIC
                ' .... snip
                SetBkMode wParam, TRANSPARENT: SetTextColor wParam, m_lFontColor
                If hBrushStatic = 0 Then hBrushStatic = CreateSolidBrush(vbYellow)
                bDiscardMessage = True: ISubclass_WndProc = hBrushStatic ' GetSysColorBrush(COLOR_BTNFACE) ' Returns a handle to a system brush with the default window background color
            Case WM_CTLCOLOREDIT
                SetBkMode wParam, TRANSPARENT: SetTextColor wParam, m_lFontColor
                If hBrushEdit = 0 Then hBrushEdit = CreateSolidBrush(vbGreen)
                bDiscardMessage = True: ISubclass_WndProc = hBrushEdit
            Case WM_DESTROY
                If DeleteObject(hBrushStatic) Then hBrushStatic = 0
                If DeleteObject(hBrushEdit) Then hBrushEdit = 0
            End Select

  37. #37
    Lively Member
    Join Date
    Nov 2023
    Posts
    75

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    I completely agree with you that sometimes forum members want the most unreasonable!!! But thank you very much for your work.

  38. #38
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Quote Originally Posted by VanGoghGaming View Post
    Sometimes, forum users want the most unreasonable of things! You can change the background colors although it doesn't look great in my opinion:

    Name:  UnicodeInputBoxColor.png
Views: 214
Size:  6.1 KB

    We need to handle the "WM_CTLCOLORSTATIC" and "WM_CTLCOLOREDIT" messages and instead of returning a system brush with the background color we create a new brush with whatever background color we want and return that instead. Unlike the system brush, this new brush will have to be deleted when we're done with it:

    Code:
            Case WM_CTLCOLORSTATIC
                ' .... snip
                SetBkMode wParam, TRANSPARENT: SetTextColor wParam, m_lFontColor
                If hBrushStatic = 0 Then hBrushStatic = CreateSolidBrush(vbYellow)
                bDiscardMessage = True: ISubclass_WndProc = hBrushStatic ' GetSysColorBrush(COLOR_BTNFACE) ' Returns a handle to a system brush with the default window background color
            Case WM_CTLCOLOREDIT
                SetBkMode wParam, TRANSPARENT: SetTextColor wParam, m_lFontColor
                If hBrushEdit = 0 Then hBrushEdit = CreateSolidBrush(vbGreen)
                bDiscardMessage = True: ISubclass_WndProc = hBrushEdit
            Case WM_DESTROY
                If DeleteObject(hBrushStatic) Then hBrushStatic = 0
                If DeleteObject(hBrushEdit) Then hBrushEdit = 0
            End Select
    if use createwibdowex ""edit,can't hook message ""WM_CTLCOLOREDIT,why?

  39. #39
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    Quote Originally Posted by VanGoghGaming View Post
    Sometimes, forum users want the most unreasonable of things! You can change the background colors although it doesn't look great in my opinion:
    [/code]
    Why reply to this on this old board? Because some things are just simple upgrades.Of course, after all the technologies are developed, these corresponding technologies can be released to a new code base article.

    Sometimes it's not that users have strange ideas, but that Microsoft should have done these things. Uch as text that supports such Unicode. Or you can set a background photo. Background color.
    Of course, the easiest way is. Recreate a dialog box with the API. Only the code will increase a lot.Or simply design a new form. The title of the form, as well as the prompt text and text box content, all need to be supported. unicode

    With the transparency property, you can either set a background image for an area, or insert an image.
    With these better features. Users can use different colors or images to create a more perfect dialog box.Can be used with twinbasic

  40. #40

    Thread Starter
    Frenzied Member VanGoghGaming's Avatar
    Join Date
    Jan 2020
    Location
    Eve Online - Mining, Missions & Market Trading!
    Posts
    1,323

    Lightbulb Re: VB6 - Original InputBox function reloaded with full Unicode support & new Edit St

    The "WM_CTLCOLOREDIT" message is sent to the parent of the "Edit" control, which is the InputBox window so that's the one you need to subclass.

    Make sure to specify the handle of the parent window in your call to CreateWindowExW:

    Code:
    HWND CreateWindowExW(
      [in]           DWORD     dwExStyle,
      [in, optional] LPCWSTR   lpClassName,
      [in, optional] LPCWSTR   lpWindowName,
      [in]           DWORD     dwStyle,
      [in]           int       X,
      [in]           int       Y,
      [in]           int       nWidth,
      [in]           int       nHeight,
      [in, optional] HWND      hWndParent, ' <-- this needs to be the hWnd of the InputBox
      [in, optional] HMENU     hMenu,
      [in, optional] HINSTANCE hInstance,
      [in, optional] LPVOID    lpParam
    );

Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width