How to overwrite suggest text in textbox during typing?

Question

I have Userform using Textbox to input date.

I'd like to show suggestion text before input like __ /__/____ (same format dd/mm/yyyy) When enter this Textbox, cursor always in beginning. When I typing, each _ symbol will be replaced by number, and skip / symbol.

For example: I just type 05041991, in Textbox will show 05/04/1991.

Please help me about this code.

Answer 1

You could do something like shown below. This code is just an example (probably not perfect).

^{Image 1: Note that only number keys and backspace were pressed.}

Put the following code into a class module and name it MaskedTextBox

Option Explicit

Public WithEvents mTextBox As MSForms.TextBox

Private mMask As String
Private mMaskPlaceholder As String
Private mMaskSeparator As String

Public Enum AllowedKeysEnum
    NumberKeys = 1     '2^0
    CharacterKeys = 2  '2^1
    'for more options next values need to be 2^2, 2^3, 2^4, …
End Enum
Private mAllowedKeys As AllowedKeysEnum

Public Sub SetMask(ByVal Mask As String, ByVal MaskPlaceholder As String, ByVal MaskSeparator As String, Optional ByVal AllowedKeys As AllowedKeysEnum = NumberKeys)
    mMask = Mask
    mMaskPlaceholder = MaskPlaceholder
    mMaskSeparator = MaskSeparator
    mAllowedKeys = AllowedKeys

    mTextBox.Text = mMask
    FixSelection
End Sub


' move selection so separators get not replaced
Private Sub FixSelection()
    With mTextBox
        Dim Sel As Long
        Sel = InStr(1, .Text, mMaskPlaceholder) - 1
        If Sel >= 0 Then
            .SelStart = Sel
            .SelLength = 1
        End If
    End With
End Sub

Private Sub mTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim tb As MSForms.TextBox
    Set tb = Me.mTextBox

    'allow paste
    If Shift = 2 And KeyCode = vbKeyV Then
        On Error Resume Next
        Dim DataObj As MSForms.DataObject
        Set DataObj = New MSForms.DataObject

        DataObj.GetFromClipboard
        Dim PasteData As String
        PasteData = DataObj.GetText(1)

        On Error GoTo 0
        If PasteData <> vbNullString Then
            Dim LikeMask As String
            LikeMask = Replace$(mMask, mMaskPlaceholder, "?")

            If PasteData Like LikeMask Then
                mTextBox = PasteData
            End If
        End If
    End If

    Select Case KeyCode
        Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
            'allow number keys
            If Not (mAllowedKeys And NumberKeys) = NumberKeys Then
                KeyCode = 0
            ElseIf Len(tb.Text) >= Len(mMask) And InStr(1, tb.Text, mMaskPlaceholder) = 0 Then
                KeyCode = 0
            End If

        Case vbKeyA To vbKeyZ
            'allow character keys
            If Not (mAllowedKeys And CharacterKeys) = CharacterKeys Then
                KeyCode = 0
            ElseIf Len(tb.Text) >= Len(mMask) And InStr(1, tb.Text, mMaskPlaceholder) = 0 Then
                KeyCode = 0
            End If

        Case vbKeyBack
            'allow backspace key
            KeyCode = 0
            If tb.SelStart > 0 Then 'only if not first character
                If Mid$(tb.Text, tb.SelStart, 1) = mMaskSeparator Then
                    'jump over separators
                    tb.SelStart = tb.SelStart - 1
                End If

                'remove character left of selection and fill in mask
                If tb.SelLength <= 1 Then
                    tb.Text = Left$(tb.Text, tb.SelStart - 1) & Mid$(mMask, tb.SelStart, 1) & Right$(tb.Text, Len(tb.Text) - tb.SelStart)
                End If
            End If

            'if whole value is selected replace with mask
            If tb.SelLength = Len(mMask) Then tb.Text = mMask

        Case vbKeyReturn, vbKeyTab, vbKeyEscape
            'allow these keys

        Case Else
            'disallow any other key
            KeyCode = 0
    End Select

    FixSelection
End Sub

Private Sub mTextBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    FixSelection
End Sub

Put the following code into your userform

Option Explicit

Private MaskedTextBoxes As Collection

Private Sub UserForm_Initialize()
    Set MaskedTextBoxes = New Collection
    Dim MaskedTextBox As MaskedTextBox

    'init TextBox1 as date textbox
    Set MaskedTextBox = New MaskedTextBox
    Set MaskedTextBox.mTextBox = Me.TextBox1
    MaskedTextBox.SetMask Mask:="__/__/____", MaskPlaceholder:="_", MaskSeparator:="/"
    MaskedTextBoxes.Add MaskedTextBox

    'init TextBox2 as barcode textbox
    Set MaskedTextBox = New MaskedTextBox
    Set MaskedTextBox.mTextBox = Me.TextBox2
    MaskedTextBox.SetMask Mask:="____-____-____", MaskPlaceholder:="_", MaskSeparator:="-", AllowedKeys:=CharacterKeys + NumberKeys
    MaskedTextBoxes.Add MaskedTextBox
End Sub