Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,779
- Office Version
- 2016
- Platform
- 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:
2- Code Usage ( UserForm Module)
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: