Option Explicit
Private WithEvents txtBox As TextBox
Private mnuContext As Menu
Private m_ErrorColor As Long
Public Sub Init(TextBox As TextBox, Optional ErrorColor As Long = vbRed, Optional ContextMenu As Menu = Nothing)
Set mnuContext = ContextMenu
m_ErrorColor = ErrorColor
Set txtBox = TextBox
End Sub
Public Property Get ErrorColor() As Long
ErrorColor = m_ErrorColor
End Property
Public Property Let ErrorColor(nNew As Long)
m_ErrorColor = nNew
End Property
Public Property Set TextBox(txt As TextBox)
Set txtBox = txt
End Property
Public Property Get TextBox() As TextBox
Set txtBox = txtBox
End Property
Public Property Set ContextMenu(mnu As Menu)
Set mnuContext = mnu
End Property
Public Property Get ContextMenu() As Menu
Set ContextMenu = mnuContext
End Property
Private Sub Class_Initialize()
m_ErrorColor = vbRed
End Sub
Private Sub txtBox_Change()
Dim nSelStart As Long, nSelLen As Long
If Len(txtBox.Text) Then
If (UCase$(txtBox.Text) Like "[A-Z]" & String(Len(txtBox.Text) - 1, "#")) Then
If UCase$(txtBox.Text) <> txtBox.Text Then
nSelStart = txtBox.SelStart
nSelLen = txtBox.SelLength
txtBox.Text = UCase$(txtBox.Text)
txtBox.SelStart = nSelStart
txtBox.SelLength = nSelLen
End If
txtBox.BackColor = vbWindowBackground
Else
txtBox.BackColor = m_ErrorColor
End If
Else
txtBox.BackColor = vbWindowBackground
End If
End Sub
Private Sub txtBox_KeyPress(KeyAscii As Integer)
Dim nSelLen As Long
nSelLen = txtBox.SelLength
If txtBox.SelStart = 0 And txtBox.SelLength = 0 Then
'This will ensure that the first character is replaced if
'the user has moved the text caret to the beginning of the text
txtBox.SelLength = 1
End If
KeyAscii = Asc(UCase$(Chr$(KeyAscii))) 'capitilize
Select Case KeyAscii
Case vbKeyBack
txtBox.SelLength = nSelLen
Case vbKeyA To vbKeyZ
If txtBox.SelStart <> 0 Then
KeyAscii = 0
txtBox.SelLength = nSelLen
Else
KeyAscii = Asc(UCase$(Chr$(KeyAscii))) 'capitilize
End If
Case vbKey0 To vbKey9
If txtBox.SelStart = 0 Then
KeyAscii = 0
txtBox.SelLength = nSelLen
End If
Case Else
KeyAscii = 0
txtBox.SelLength = nSelLen
End Select
End Sub
Private Sub txtBox_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not mnuContext Is Nothing Then
If Button And vbRightButton Then
'surpress the default context menu and show our custom menu instead
txtBox.Enabled = False
txtBox.Enabled = True
txtBox.Parent.PopupMenu mnuContext
End If
End If
End Sub