Textbox Number Control
cNumControl - Textbox Number Control
Option Explicit
Private WithEvents txtNum As MSForms.TextBox
'Private m_oCollectionOfEventHandlers As Collection
Enum TxtDecimalType
nbAuto = 0
nbFixed = 1
End Enum
Enum TxtAlignmentConstants
nbLeft = 1
nbCenter = 2
nbRight = 3
End Enum
Enum TxtFormat
nbStandard = 0
nbCurrency = 1
End Enum
Enum TxtNegativeChar
nbMinus = 0
nbParenthesis = 1
End Enum
Dim m_DecimalPlaces As Byte
Dim m_DecimalType As TxtDecimalType
Dim DecCnt As Byte 'save count of number after decimal
Dim m_Format As TxtFormat
Dim m_NegativeAllow As Boolean
Dim m_NegativeChar As TxtNegativeChar
Dim m_TextIfNothing As String
Dim m_ThousandSeparator As Boolean
'default value
Const m_def_DecimalPlaces = 2
Const m_def_DecimalType = 0
Const m_def_Format = 0
Const m_def_NegativeAllow = True
Const m_def_NegativeChar = 0
Const m_def_ThousandSeparator = True
Dim DCr As String 'save decimal character
Dim SCr As String 'save thousand separator character
'event declaration
Event Change()
Event Click()
Event DblClick()
Event KeyDown(ByVal KeyCode As Integer, Shift As Integer)
Event KeyPress(ByVal KeyAscii As Integer)
Event KeyUp(ByVal KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Property Set Init(ByRef controlObject As Object)
If TypeOf controlObject Is MSForms.TextBox Then
Set txtNum = controlObject
'initialize default value
m_DecimalPlaces = m_def_DecimalPlaces
m_DecimalType = m_def_DecimalType
m_Format = m_def_Format
m_NegativeAllow = m_def_NegativeAllow
m_NegativeChar = m_def_NegativeChar
m_ThousandSeparator = m_def_ThousandSeparator
txtNum.Text = "0"
End If
End Property
Sub ReFormat()
'txtNum.Refresh
If txtNum.Text = "" Then
txtNum.Text = m_TextIfNothing
End If
If txtNum.Text = "" Then Exit Sub
On Error GoTo Ero
Dim strTemp As String
DCr = Mid(5 / 2, 2, 1)
SCr = Mid(FormatNumber(1000, 0), 2, 1)
txtNum.Text = Replace(txtNum.Text, SCr, "")
If m_NegativeAllow = False Then txtNum.Text = Abs(CDbl(txtNum.Text))
'count number after decimal (DecCnt)
If m_DecimalType = 0 Then 'auto
If InStr(txtNum.Text, DCr) Then 'if find decimal
strTemp = Split(txtNum.Text, DCr)(1) 'get text on right of decimal
strTemp = Replace(strTemp, ")", "") 'remove parensthesis
DecCnt = Len(strTemp)
Else
DecCnt = 0
End If
Else 'fixed
DecCnt = m_DecimalPlaces
End If
'format property
Select Case m_Format
Case 0 'standard
If m_NegativeChar = 0 Then
txtNum.Text = FormatNumber(txtNum.Text, DecCnt)
Else
txtNum.Text = FormatNumber(txtNum.Text, DecCnt, , vbTrue)
End If
Case 1 'currency
If m_NegativeChar = 0 Then
txtNum.Text = FormatCurrency(txtNum.Text, DecCnt, , vbFalse)
Else
txtNum.Text = FormatCurrency(txtNum.Text, DecCnt)
End If
End Select
'if auto and find decimal
If m_DecimalType = 0 And InStr(txtNum.Text, DCr) Then
strTemp = Split(txtNum.Text, DCr)(1)
txtNum.Text = Left(txtNum.Text, Len(txtNum.Text) - Len(strTemp)) 'remove strTemp from txtNum
strTemp = Replace(strTemp, ")", "") 'remove parensthesis
Do While Right(strTemp, 1) = "0"
strTemp = Left(strTemp, Len(strTemp) - 1) 'clear zero
Loop
If strTemp = "" Then 'if nothing
txtNum.Text = Replace(txtNum.Text, DCr, "") 'remove decimal
Else
txtNum.Text = txtNum.Text & strTemp 'join again
End If
If InStr(txtNum.Text, "(") Then txtNum.Text = txtNum.Text & ")" 'if find "("
End If
'ThousandSeparator property
If m_ThousandSeparator = False Then
txtNum.Text = Replace(txtNum.Text, SCr, "") 'remove separator
End If
Exit Sub
Ero:
MsgBox Err.Description & " :" & vbCrLf & txtNum.Text, vbExclamation
txtNum.SetFocus
End Sub
Private Sub txtNum_Change()
RaiseEvent Change
End Sub
Private Sub txtNum_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
RaiseEvent DblClick
End Sub
'Private Sub txtNum_Click()
' RaiseEvent Click
'End Sub
Public Sub Control_GotFocus()
On Error Resume Next
'if currency
If m_Format = 1 And txtNum.Text <> "" Then txtNum.Text = FormatNumber(txtNum.Text, DecCnt)
'if find parensthesis
If Left(txtNum.Text, 1) = "(" And Right(txtNum.Text, 1) = ")" Then
txtNum.Text = Mid(txtNum.Text, 2, Len(txtNum.Text) - 2)
txtNum.Text = "-" & txtNum.Text 'add minus
End If
SendKeys "{home}+{end}"
End Sub
Private Sub txtNum_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If Shift = 1 And KeyCode = 45 Then 'paste (shift + insert)
'If Not IsNumeric(Clipboard.GetText) Then Clipboard.Clear
End If
RaiseEvent KeyDown(KeyCode, Shift)
End Sub
Private Sub txtNum_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Dim intPosition As Integer
DCr = Mid(5 / 2, 2, 1)
SCr = Mid(FormatNumber(1000, 0), 2, 1)
intPosition = InStrRev(txtNum.Text, DCr)
Select Case KeyAscii
Case 48 To 58 '0 - 9
If intPosition > 0 Then
If txtNum.SelStart >= intPosition Then 'right of decimal
If m_DecimalType = 1 Then 'fixed
If (Len(txtNum.Text) - intPosition + 1) > m_DecimalPlaces Then KeyAscii = 0
End If
End If
End If
Case 45 ' "-" negatif
If m_NegativeAllow = False Or txtNum.SelStart <> 0 Then
KeyAscii = 0
End If
Case 8, 13, 27 'backspace, enter, esc
Case 24, 3 'cut, copy
Case 22 'paste (ctrl + v)
' If Not IsNumeric(Clipboard.GetText) Then Clipboard.Clear 'if not numeric
Case Else
If Chr(KeyAscii) = DCr Then 'if decimal
'if find other decimal
If InStr(txtNum.Text, DCr) Then KeyAscii = 0
'if fixed and 0
If m_DecimalType = 1 And m_DecimalPlaces = 0 Then KeyAscii = 0
ElseIf Chr(KeyAscii) = SCr Then 'tho separator
If intPosition > 0 Then
If txtNum.SelStart >= intPosition Then KeyAscii = 0 'right of decimal
End If
If m_ThousandSeparator = False Then KeyAscii = 0
Else 'other character
KeyAscii = 0
End If
End Select
RaiseEvent KeyPress(KeyAscii)
End Sub
Public Property Get Alignment() As TxtAlignmentConstants
Alignment = txtNum.TextAlign
End Property
Public Property Let Alignment(ByVal New_Alignment As TxtAlignmentConstants)
txtNum.TextAlign = New_Alignment
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = txtNum.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
txtNum.BackColor = New_BackColor
'Call UserControl_Resize
End Property
Public Property Get DecimalPlaces() As Byte
DecimalPlaces = m_DecimalPlaces
End Property
Public Property Let DecimalPlaces(ByVal New_DecimalPlaces As Byte)
If New_DecimalPlaces > 15 Then New_DecimalPlaces = 15
m_DecimalPlaces = New_DecimalPlaces
'PropertyChanged "DecimalPlaces"
Call ReFormat
End Property
Public Property Get DecimalType() As TxtDecimalType
DecimalType = m_DecimalType
End Property
Public Property Let DecimalType(ByVal New_DecimalType As TxtDecimalType)
m_DecimalType = New_DecimalType
'PropertyChanged "DecimalType"
Call ReFormat
End Property
Public Property Get Enabled() As Boolean
Enabled = txtNum.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
txtNum.Enabled = New_Enabled
'PropertyChanged "Enabled"
End Property
Public Property Get Font() As Font
Set Font = txtNum.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set txtNum.Font = New_Font
'PropertyChanged "Font"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = txtNum.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
txtNum.ForeColor = New_ForeColor
'PropertyChanged "ForeColor"
End Property
Public Property Get Format() As TxtFormat
Format = m_Format
End Property
Public Property Let Format(ByVal New_Format As TxtFormat)
m_Format = New_Format
'PropertyChanged "Format"
Call ReFormat
End Property
Public Property Get Locked() As Boolean
Locked = txtNum.Locked
End Property
Public Property Let Locked(ByVal New_Locked As Boolean)
txtNum.Locked = New_Locked
'PropertyChanged "Locked"
End Property
Public Property Get MousePointer() As MousePointerConstants
MousePointer = txtNum.MousePointer
End Property
Public Property Let MousePointer(ByVal New_MousePointer As MousePointerConstants)
txtNum.MousePointer = New_MousePointer
'PropertyChanged "MousePointer"
End Property
Public Property Get NegativeAllow() As Boolean
NegativeAllow = m_NegativeAllow
End Property
Public Property Let NegativeAllow(ByVal New_NegativeAllow As Boolean)
If New_NegativeAllow = True Then GoTo Okk 'if true, jump to Okk
'check Text property
If txtNum.Text <> "" Then
If CDbl(txtNum.Text) < 0 Then
MsgBox "Invalid propety on [Text] !", vbExclamation, "Negative Allow Property"
Exit Property
End If
End If
'check TextIfNothing property
If m_TextIfNothing <> "" Then
If CDbl(m_TextIfNothing) < 0 Then
MsgBox "Invalid propety on [TextIfNothing] !", vbExclamation, "Negative Allow Property"
Exit Property
End If
End If
Okk:
m_NegativeAllow = New_NegativeAllow
'PropertyChanged "NegativeAllow"
End Property
Public Property Get NegativeChar() As TxtNegativeChar
NegativeChar = m_NegativeChar
End Property
Public Property Let NegativeChar(ByVal New_NegativeChar As TxtNegativeChar)
m_NegativeChar = New_NegativeChar
'PropertyChanged "NegativeChar"
Call ReFormat
End Property
Public Property Get Text() As String
On Error GoTo Enn
' If Ambient.UserMode = True Then
Text = txtNum.Text
' Else
' Text = CDbl(txtNum.Text)
' End If
Exit Property
Enn:
Text = ""
End Property
Public Property Let Text(ByVal New_Text As String)
If New_Text = "" Then GoTo Okk 'if blank, jump to Okk
'if not numeric
If Not IsNumeric(New_Text) Then
MsgBox "Please enter numbers only !", vbExclamation, "Text Property"
Exit Property
End If
'if can't negative
If m_NegativeAllow = False Then
If CDbl(New_Text) < 0 Then
MsgBox "The value of [Text] can't negative !", vbExclamation, "Text Property"
Exit Property
End If
End If
Okk:
txtNum.Text = New_Text
'PropertyChanged "Text"
Call ReFormat
End Property
Public Property Get TextIfNothing() As String
TextIfNothing = m_TextIfNothing
End Property
Public Property Let TextIfNothing(ByVal New_TextIfNothing As String)
If New_TextIfNothing = "" Then GoTo Okk
'if not numeric
If Not IsNumeric(New_TextIfNothing) Then
MsgBox "Please enter numbers only !", vbExclamation, "Text If Nothing Property"
Exit Property
End If
'if can't negative
If m_NegativeAllow = False Then
If CDbl(New_TextIfNothing) < 0 Then
MsgBox "The value of [TextIfNothing] can't negative !", vbExclamation, "Text If Nothing Property"
Exit Property
End If
End If
Okk:
m_TextIfNothing = New_TextIfNothing
'PropertyChanged "TextIfNothing"
Call ReFormat
End Property
Public Property Get ThousandSeparator() As Boolean
ThousandSeparator = m_ThousandSeparator
End Property
Public Property Let ThousandSeparator(ByVal New_ThousandSeparator As Boolean)
m_ThousandSeparator = New_ThousandSeparator
'PropertyChanged "ThousandSeparator"
Call ReFormat
End Property
Public Property Get Value() As Double
On Error GoTo Enn
Value = CDbl(Replace(txtNum.Text, SCr, ""))
Exit Property
Enn:
Value = 0
End Property
Public Property Let Value(ByVal New_Value As Double)
'if can't negative
If m_NegativeAllow = False Then
If CDbl(New_Value) < 0 Then
MsgBox "The value can't negative !", vbExclamation, "Value Property"
Exit Property
End If
End If
txtNum.Text = New_Value
'PropertyChanged "Value"
Call ReFormat
End Property
Public Sub Control_LostFocus()
Call ReFormat
End Sub
Private Sub txtNum_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
End Sub
Private Sub txtNum_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'right click for cancel paste
'If Button = 2 And IsNumeric(Clipboard.GetText) = False Then Clipboard.Clear
RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
Private Sub txtNum_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
Private Sub txtNum_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
Private Sub Class_Initialize()
' Set m_oCollectionOfEventHandlers = New Collection
End Sub