Date Input Mask ( Applying a Watermark to TextBox)

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,813
Office Version
  1. 2016
Platform
  1. Windows
Hi dear forum,

I just thought I would post this little demo here which, just like the thread title reads, it shows an attempt to mimic the watermarks that we sometimes see in some web forms.

I was spurred to it by the question asked in this recent thread ... The result I have obtained looks better than I initially anticipated ( particularly the fact that the watermark text string is interactive while typing, the fact that it borrows the font from the textbox and the watermark text doesn't spill out of the textbox rectangle).

Limitations:
1-The navigation keys are restricted to vbKeyBack to prevent messing with the date input rule\mask ( Either DD/MM/YYYY or MM/DD/YYYY )
2- The watermark is only displayed when the textbox gains\has focus.
3- If you have this applied to more that a single textbox, they all must have the same parent container.

Workbook Demo:
TextBoxDateInputMask.xlsm






1- Code in a Standard Module:
VBA Code: 
Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DrawState Lib "user32" Alias "DrawStateW" (ByVal hDC As LongPtr, ByVal hBrush As LongPtr, ByVal lpDrawStateProc As LongPtr, ByVal lParam As LongPtr, ByVal wParam As LongPtr, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function DrawState Lib "user32" Alias "DrawStateW" (ByVal hDC As LongPtr, ByVal hBrush As LongPtr, ByVal lpDrawStateProc As LongPtr, ByVal lParam As LongPtr, ByVal wParam As LongPtr, ByVal n1 As Long, ByVal n2 As Long, ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
    Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If

Private sDateFormat As String, sErrMsg As String
Private oForm As UserForm, oTextBox As MSForms.TextBox, oFeedbackCtrl As MSForms.Label
Private sngErrMsgTimer As Single


' ________________________________________ PRIVATE ROUTINES ____________________________________________

Public Sub AddDateInputMask( _
    ByVal Textbx As MSForms.TextBox, _
    Optional ByVal DateFormat As String = "DD/MM/YYYY", _
    Optional FeedbackCtrl As MSForms.Control _
)

    If DateFormat <> "DD/MM/YYYY" And DateFormat <> "MM/DD/YYYY" Then
        If Not FeedbackCtrl Is Nothing Then
            FeedbackCtrl.Caption = ""
        End If
        
        Set oTextBox = Nothing
        
        MsgBox "You supplied an incorrect date mask for TextBox " & _
                Textbx.Name & vbNewLine & vbNewLine & _
                "The format of the date input mask must be:" & _
                vbNewLine & "'DD/MM/YYYY' or 'MM/DD/YYYY'.", vbCritical
        Exit Sub
    End If
    
    Set oForm = GetUserForm(Textbx)
    Set oTextBox = Textbx
    sDateFormat = DateFormat
    oTextBox.Tag = oTextBox.Name & " hasMask"
    oTextBox.TextAlign = fmTextAlignLeft
    If Not FeedbackCtrl Is Nothing Then
        Set oFeedbackCtrl = FeedbackCtrl
        oFeedbackCtrl.Caption = ""
    End If

    Application.OnTime Now, "DrawWatermarkMask"

End Sub


Public Sub RemoveDateInputMask(ByVal TextBox As MSForms.TextBox)
    On Error Resume Next
    sDateFormat = ""
    oTextBox.Tag = ""
    oFeedbackCtrl.Caption = ""
    Set oForm = Nothing
    Set TextBox = Nothing
    Set oFeedbackCtrl = Nothing
End Sub


Public Sub KeyDownEventHandler( _
    ByVal TextBox As MSForms.TextBox, _
    ByVal KeyCode As MSForms.ReturnInteger, _
    ByVal Shift As Integer _
)

    Const MAPVK_VK_TO_CHAR = 2&
    Dim lVKey As Long, lSelStart As Long
  
    If oTextBox Is Nothing Then Exit Sub
    
    If Not oFeedbackCtrl Is Nothing Then
        oFeedbackCtrl.Caption = ""
    End If

    lSelStart = TextBox.SelStart

    Select Case KeyCode
        Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
            If Len(TextBox) = 10& Or lSelStart < Len(TextBox) Then
                KeyCode = 0&: Exit Sub
            End If
            If TextBox.SelStart = 2& Then TextBox = TextBox & "/": lSelStart = lSelStart + 1&
            If TextBox.SelStart = 5& Then TextBox = TextBox & "/": lSelStart = lSelStart + 1&
            lVKey = Chr(MapVirtualKey(KeyCode, MAPVK_VK_TO_CHAR))
            If sDateFormat = "DD/MM/YYYY" Then
                Select Case lSelStart
                    Case 0&
                        If lVKey > 3& Then
                            KeyCode = 0&: sErrMsg = "Days between 1-31"
                        End If
                    Case 1&
                        If lVKey > 1& And Left(TextBox, 1&) = 3& Then
                            KeyCode = 0&: sErrMsg = "Days between 1-31"
                        End If
                        If lVKey = 0& And Left(TextBox, 1&) = 0& Then
                            KeyCode = 0&: sErrMsg = "Days between 1-31"
                        End If
                    Case 3&
                        If lVKey > 1& Then
                            KeyCode = 0&: sErrMsg = "Months between 1-12"
                        End If
                    Case 4&
                        If lVKey > 2& And Mid(TextBox, 4&, 1&) = 1& Then
                            KeyCode = 0&: sErrMsg = "Months between 1-12"
                        End If
                        If lVKey = 0& And Mid(TextBox, 4&, 1&) = 0& Then
                            KeyCode = 0&: sErrMsg = "Months between 1-12"
                        End If
                End Select
            Else
                Select Case lSelStart
                    Case 0&
                        If lVKey > 1& Then
                            KeyCode = 0&: sErrMsg = "Months between 1-12"
                        End If
                    Case 1&
                        If lVKey > 2& And Left(TextBox, 1&) = 1& Then
                            KeyCode = 0&: sErrMsg = "Months between 1-12"
                        End If
                        If lVKey = 0& And Left(TextBox, 1&) = 0& Then
                            KeyCode = 0&: sErrMsg = "Months between 1-12"
                        End If
                    Case 3&
                        If lVKey > 3& Then
                            KeyCode = 0&: sErrMsg = "Days between 1-31"
                        End If
                    Case 4&
                        If lVKey > 1& And Mid(TextBox, 4&, 1&) = 3& Then
                            KeyCode = 0&: sErrMsg = "Days between 1-31"
                        End If
                        If lVKey = 0& And Mid(TextBox, 4&, 1&) = 0& Then
                            KeyCode = 0&: sErrMsg = "Days between 1-31"
                        End If
                End Select
            End If
            If lSelStart = 9& Then
                If lVKey = 0& And Mid(TextBox, 7&, 3&) = "000" Then
                    KeyCode = 0&: sErrMsg = "Year between 1-9999"
                End If
                If Not IsDate(TextBox & lVKey) Then
                    KeyCode = 0&: sErrMsg = Right(TextBox, 3) & lVKey & " is not a leap year."
                End If
            End If
        Case vbKeyA To vbKeyZ
            KeyCode = 0&
        Case vbKeyBack
            If lSelStart < Len(TextBox) Then
                KeyCode = 0&: sErrMsg = "You can only use the Back-Key on the last character."
            End If
        Case vbKeyDelete
            If TextBox.SelLength < Len(TextBox) Then
                KeyCode = 0&: sErrMsg = "Select the entire text to delete."
            End If
        Case vbKeyLeft, vbKeyRight, vbKeyHome, vbKeyEnd
            If Shift <> 2& And GetAsyncKeyState(vbKeyShift) = 0& Then
                KeyCode = 0&: sErrMsg = "Navigation keys disallowed except the Back-Key."
            End If
        Case vbKeyReturn, vbKeyTab, vbKeyEscape
        Case Else
            KeyCode = 0&
    End Select

    If Not oFeedbackCtrl Is Nothing Then
        If Len(sErrMsg) Then
            sErrMsg = "Error!" & vbNewLine & sErrMsg
            sngErrMsgTimer = Timer: Beep
            Application.OnTime Now, "ShowErrMsg"
        End If
    End If
    
End Sub


' ________________________________________ PRIVATE ROUTINES ____________________________________________

Private Sub DrawWatermarkMask()

    Const DSS_DISABLED = &H20
    Const DST_TEXT = &H1
    
    Dim hwnd As LongPtr, hDC As LongPtr, hRgn As LongPtr, hPrevFont As LongPtr
    Dim tFormRect As RECT, tPrevFormRect As RECT, tTextBoxRect As RECT, tDrawRect As RECT
    Dim tCaretPos As POINTAPI
    Dim sCurText As String, sPrevText As String, sMaskUpdate As String
    Dim IFont As stdole.IFont
    

    Call IUnknown_GetWindow(oTextBox.Parent, VarPtr(hwnd))
    hDC = GetDC(hwnd)

    Set IFont = oTextBox.Font
    hPrevFont = SelectObject(hDC, IFont.hFont)

    If Not oForm Is Nothing Then
        With tTextBoxRect
            .Left = PTtoPX(oTextBox.Left, False)
            .Top = PTtoPX(oTextBox.Top, True)
            .Right = PTtoPX(oTextBox.Width, False)
            .Bottom = PTtoPX(oTextBox.Height, True)
            hRgn = CreateRectRgn(.Left, .Top, .Left + .Right, .Top + .Bottom)
        End With
        Call SelectClipRgn(hDC, hRgn)
    End If

    oTextBox.SelStart = Len(oTextBox)

    Do
        DoEvents
        On Error Resume Next
            If IsWindow(hwnd) = 0& Or Len(oTextBox.Tag) = 0& Then
                sErrMsg = ""
                If Not oFeedbackCtrl Is Nothing Then
                    oFeedbackCtrl.Caption = sErrMsg
                End If
                Exit Do
            End If
        On Error GoTo 0
        
        If Not oFeedbackCtrl Is Nothing Then
            If Timer - sngErrMsgTimer >= 3& Then
                sErrMsg = ""
                oFeedbackCtrl.Caption = sErrMsg
            End If
        End If
         
        Call GetCaretPos(tCaretPos)
        Call GetWindowRect(hwnd, tFormRect)
        Call SetRect(tDrawRect, tCaretPos.X, tCaretPos.Y, tFormRect.Right, tFormRect.Bottom)
        
        sCurText = oTextBox.Text
        sMaskUpdate = Mid(sDateFormat, Len(sCurText) + 1&, 10&)
    
        If sPrevText <> sCurText Or tPrevFormRect.Left <> tFormRect.Left Then
            Call DrawState(hDC, NULL_PTR, NULL_PTR, StrPtr(sMaskUpdate), Len(sMaskUpdate), _
                 tDrawRect.Left, tDrawRect.Top, tDrawRect.Right - tDrawRect.Left, _
                 tDrawRect.Bottom - tDrawRect.Top, DST_TEXT + DSS_DISABLED)
        End If
    
        tPrevFormRect = tFormRect
        sPrevText = oTextBox.Text
    Loop

    Call SelectClipRgn(hDC, NULL_PTR)
    Call SelectObject(hDC, hPrevFont)
    Call DeleteObject(hRgn)
    Call ReleaseDC(hwnd, hDC)

End Sub

Private Sub ShowErrMsg()
    If Not oFeedbackCtrl Is Nothing Then
        oFeedbackCtrl.Caption = sErrMsg
    End If
    sErrMsg = ""
End Sub

Private Function GetUserForm(ByVal Ctrl As MSForms.Control) As UserForm
    Dim oTmp As Object
    Set oTmp = Ctrl.Parent
    Do While TypeOf oTmp Is MSForms.Control
        Set oTmp = oTmp.Parent
    Loop
    Set GetUserForm = oTmp
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Const LOGPIXELSX = 88&, LOGPIXELSY = 90&
    Static lDPI(1&) As Long, hDC As LongPtr
    If lDPI(0&) = 0& Then
        hDC = GetDC(NULL_PTR)
        lDPI(0&) = GetDeviceCaps(hDC, LOGPIXELSX)
        lDPI(1&) = GetDeviceCaps(hDC, LOGPIXELSY)
        Call ReleaseDC(NULL_PTR, hDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    Const POINTSPERINCH = 72&
    PTtoPX = (Points * ScreenDPI(bVert) / POINTSPERINCH) * oForm.Zoom / 100&
End Function



2- Code Usage ( UserForm Module)
VBA Code: 
Option Explicit

Private Sub TextBox1_Enter()
    Call AddDateInputMask(Me.TextBox1, "DD/MM/YYYY", Me.Label1)
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call RemoveDateInputMask(TextBox1)
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Call KeyDownEventHandler(TextBox1, KeyCode, Shift)
End Sub


Private Sub TextBox2_Enter()
    Call AddDateInputMask(Me.TextBox2, "MM/DD/YYYY", Me.Label1)
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Call RemoveDateInputMask(TextBox2)
End Sub

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Call KeyDownEventHandler(TextBox2, KeyCode, Shift)
End Sub
 
Last edited:

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Hi

Very nice work ;) I salute the performance👍

But too gas factory in my eyes, I prefer to test the validity of the date after entry 😁
 
Upvote 0
Again ... the Input Mask Idea is simply Brilliant ...

It provides all Users with a very simple AND intuitive framework...
which is 100% in line with the basic idea of a UserForm implemented to make life easier for Users.(y):cool:(y)
 
Upvote 0
Jaafar Tribak said:
Sure... "After-entry data validation" is no doubt the easiest and works alaways but, I couldn't resist trying to experiment with the input mask idea :)
Click to expand...
@Jaafar Tribak
Sir, I have been trying to produce something like this for months! I'm relatively new to VBA, so when I saw your code I realised that maybe I had bitten off more than I could chew, in a manner of speaking. The validation of data input is relatively easy, but the auto input of the the data delimiters, without having to input them is, I must say priceless, when I and my colleagues input thousands of these into a a hashed up spreadsheet during every trip in the format of [dd/mm/yyyy_hh:mm]. I am currently trying to get my head around your code and learn from it so I may produce a solution that will work for us. To this end, may I ask your permission, if my current skillset will allow it, to adapt your code to make our lives that much easier?

If you are agreeable, I have two questions, if I may:
  1. Am I correct in my interpretation of your code that the returned value from the user form would be interpreted by excel as a date, and could be further processed as such?
  2. Would you be able to give me some pointers as to how to:
a. Chand the Userform1 to only show the UK date input.​
b. change the format if the required input to dd/mm/yyyy_hh:mm.​
​
Thank you very much for sharing this with the forum. I do not exaggerate when I say it is a work of art! One that I have been trying to replicate for more long and frustrating nights that I care to recall.

Kindest regards
D.
 
Upvote 0
Hi Davmacrat

Thanks for the feedback .

1- Yes. The returned value from the user form would be interpreted by excel as a date, and could be further processed as such.
2-
a- Yes. the DD/MM/YYYY is possible as shown in the first textbox in the demo clip above.
b- Input masking and validating in the format dd/mm/yyyy hh:mm should be possible but would require some code tweaking ... I am busy at the moment but when I get the time, I will try to adapt the code.
 
Upvote 1
You must log in or register to reply here.

Similar threads

M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
377
Minh Tuan VN
M
S
  • Solved
Hide userform title bar, and locking the userform into a relative position on the application.
2
Replies
16
Views
811
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
926
Jaafar Tribak
Jaafar Tribak
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
797
huiettcm
H
T
  • Solved
Chart point must move to point of click in chart
Replies
2
Views
712
tigger_na
T

Forum statistics

Threads
1,224,989
Messages
6,182,205
Members
453,094
Latest member
MagicSteve

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top