Auto formatting and auto validating TextBox VBA

Question

So, I created a class to avoid all the work behind the validation of input in a textbox.

The idea is to pass an existing textbox and a type of the desired content and the class will take care of block unacceptable input (for example letters in a numeric textbox), validate the text while the user writes and display a message if the content is invalid.

Exposed Methods

Create: associates the existing textbox to the class, set the content type, and set appearance properties
Validate: checks validity of content and display the message

Exposed properties

TextBoxType: Let|Get custom - content type
MaxValue: Let|Get double - only valid for numeric types
MinValue: Let|Get double - only valid for numeric types
FixedFormat: Let|Get boolean - only valid for numeric types, maintain the format of the number while typing
ToCase: Let|Get custom - only valid for non-numeric types, change the case of the string while typing
InvalidValueMessage: Let|Get string - message showed by the Validate function if the content is not vald
IsValid: Get boolean - content validity by the type expected
ShowValidityThrough: Let|Get custom - IsValid property can colour the textbox to indicate to the user if the content is valid or not. You can choose to colour backcolor, forecolor or bordercolor
ValidColor: Let|Get long - the color of the ShowValidityThrough property if the content is valid
InvalidColor: Let|Get long - the colour of the ShowValidityThrough property if the content is not valid

I would like to have some advice if you can on the design and on the possible errors you can see. Also advises on other possible types are very welcome! Thank you!

Class Name AdvTextBox

Option Explicit

Private WithEvents txt                      As MSForms.TextBox

' properties storage
Private pTextBoxType                        As TextBoxTypes
Private pMaxValue                           As Double
Private pMinValue                           As Double
Private pFixedFormat                        As Boolean
Private pToCase                             As DesiredCase
Private pInvalidValueMessage                As String
Private pIsValid                            As Boolean
Private pShowValidityThrough                As ValidityProperty
Private pValidColor                         As Long
Private pInvalidColor                       As Long

' calculated
Private pAllowedCharacters                  As String
Private pEvaluateMinMax                     As Boolean
Private pAllowEvents                        As Boolean
Private pOutputFormat                       As String
Private pEnlarged                           As Boolean
Private DecimalSeparator                    As String

' constants
Private Const numbers                       As String = "0123456789"
Private Const letters                       As String = "abcdefghijklmnopqrstuvwxyz"
Private Const accented                      As String = "èéàòì"
Private Const numberPunctuation             As String = ",."
Private Const otherPunctuation              As String = " !?=_/|-@€+"
Private Const defaultInvalidColor           As Long = &H5F5BDD

Public Enum TextBoxTypes
    ShortText = 0
    Notes = 1
    Iban = 10
    ItalianVatNumber = 11
    Email = 12
    WholeNumber = 20
    Decimal1Digit = 21
    Decimal2Digit = 22
    Decimal3Digit = 23
    Decimal4Digit = 24
    Decimal5Digit = 25
    Decimal6Digit = 26
End Enum

Public Enum DesiredCase
    Normal = 0
    UpperCase = 1
    LowerCase = 2
    ProperCase = 3
End Enum

Public Enum ValidityProperty
    NoOne = 0
    vBorders = 1
    vBackColor = 2
    vForeColor = 3
End Enum

' class
Private Sub Class_Initialize()
    DecimalSeparator = Application.DecimalSeparator
    pAllowEvents = True
    pFixedFormat = True
    pShowValidityThrough = NoOne
    pToCase = Normal
    pValidColor = -1
    pInvalidColor = -1
End Sub

' let properties
Public Property Let InvalidValueMessage(value As String)
    pInvalidValueMessage = value
End Property

Public Property Let ShowValidityThrough(value As ValidityProperty)
    pShowValidityThrough = value
    ColorTextBox pIsValid
End Property

Public Property Let ValidColor(value As Long)
    pValidColor = value
    ColorTextBox pIsValid
End Property

Public Property Let InvalidColor(value As Long)
    pInvalidColor = value
    ColorTextBox pIsValid
End Property

Public Property Let ToCase(value As DesiredCase)
    pToCase = value
End Property

Public Property Let FixedFormat(value As Boolean)
    pFixedFormat = value
    Select Case pTextBoxType
        Case WholeNumber
            pOutputFormat = "#,##0"
            pAllowedCharacters = numbers
        Case Decimal1Digit
            pOutputFormat = "#,##0.0"
            pAllowedCharacters = numbers & IIf(value, vbNullString, numberPunctuation)
        Case Decimal2Digit
            pOutputFormat = "#,##0.00"
            pAllowedCharacters = numbers & IIf(value, vbNullString, numberPunctuation)
        Case Decimal3Digit
            pOutputFormat = "#,##0.000"
            pAllowedCharacters = numbers & IIf(value, vbNullString, numberPunctuation)
        Case Decimal4Digit
            pOutputFormat = "#,##0.0000"
            pAllowedCharacters = numbers & IIf(value, vbNullString, numberPunctuation)
        Case Decimal5Digit
            pOutputFormat = "#,##0.00000"
            pAllowedCharacters = numbers & IIf(value, vbNullString, numberPunctuation)
        Case Decimal6Digit
            pOutputFormat = "#,##0.000000"
            pAllowedCharacters = numbers & IIf(value, vbNullString, numberPunctuation)
    End Select
End Property

Private Property Let IsValid(value As Boolean)
    pIsValid = value
    ColorTextBox value
End Property

Public Property Let MinValue(value As Double)
    pEvaluateMinMax = True
    pMinValue = value
End Property

Public Property Let MaxValue(value As Double)
    pEvaluateMinMax = True
    pMaxValue = value
End Property

Private Property Let TextBoxType(value As TextBoxTypes)
        
    Dim text        As String
    Dim maxLength   As Long
    
    pTextBoxType = value
    
    Select Case value
        Case ShortText
            maxLength = 40
            pAllowedCharacters = numbers & letters & numberPunctuation & otherPunctuation
        Case Notes
            txt.EnterKeyBehavior = True
            txt.MultiLine = True
            pAllowedCharacters = numbers & letters & numberPunctuation & otherPunctuation & accented & Chr(10) & Chr(13)
        Case Iban
            maxLength = 31
            pAllowedCharacters = numbers & letters
        Case ItalianVatNumber
            maxLength = 11
            pAllowedCharacters = numbers
        Case Email
            pAllowedCharacters = numbers & letters & numberPunctuation & otherPunctuation
        Case WholeNumber
            text = 0
            pOutputFormat = "#,##0"
            pAllowedCharacters = numbers
            txt.ControlTipText = "Press ""-"" to change the sign"
        Case Decimal1Digit
            text = 0
            pOutputFormat = "#,##0.0"
            pAllowedCharacters = numbers & IIf(pFixedFormat, vbNullString, numberPunctuation)
            txt.ControlTipText = "Press ""-"" to change the sign"
        Case Decimal2Digit
            text = 0
            pOutputFormat = "#,##0.00"
            pAllowedCharacters = numbers & IIf(pFixedFormat, vbNullString, numberPunctuation)
            txt.ControlTipText = "Press ""-"" to change the sign"
        Case Decimal3Digit
            text = 0
            pOutputFormat = "#,##0.000"
            pAllowedCharacters = numbers & IIf(pFixedFormat, vbNullString, numberPunctuation)
            txt.ControlTipText = "Press ""-"" to change the sign"
        Case Decimal4Digit
            text = 0
            pOutputFormat = "#,##0.0000"
            pAllowedCharacters = numbers & IIf(pFixedFormat, vbNullString, numberPunctuation)
            txt.ControlTipText = "Press ""-"" to change the sign"
        Case Decimal5Digit
            text = 0
            pOutputFormat = "#,##0.00000"
            pAllowedCharacters = numbers & IIf(pFixedFormat, vbNullString, numberPunctuation)
            txt.ControlTipText = "Press ""-"" to change the sign"
        Case Decimal6Digit
            text = 0
            pOutputFormat = "#,##0.000000"
            pAllowedCharacters = numbers & IIf(pFixedFormat, vbNullString, numberPunctuation)
            txt.ControlTipText = "Press ""-"" to change the sign"
    End Select
    
    If maxLength > 0 Then txt.maxLength = maxLength
    txt.text = text
    
End Property
    
' get properties
Public Property Get InvalidValueMessage() As String
    InvalidValueMessage = pInvalidValueMessage
End Property

Public Property Get ShowValidityThrough() As ValidityProperty
    ShowValidityThrough = pShowValidityThrough
End Property

Public Property Get ToCase() As DesiredCase
    ToCase = pToCase
End Property

Public Property Get FixedFormat() As Boolean
    FixedFormat = pFixedFormat
End Property
    
Public Property Get MaxValue() As Double
    MaxValue = pMaxValue
End Property

Public Property Get MinValue() As Double
    MinValue = pMinValue
End Property

Public Property Get IsValid() As Boolean
    ColorTextBox pIsValid
    IsValid = pIsValid
End Property

Public Property Get ValidColor() As Long
    ValidColor = pValidColor
End Property

Public Property Get InvalidColor() As Long
    InvalidColor = pInvalidColor
End Property

Private Property Get TextBoxType() As TextBoxTypes
    TextBoxType = pTextBoxType
End Property
    
' exposed methods and functions
Public Function Create(ByVal obj As MSForms.TextBox, _
                    ByVal txtType As TextBoxTypes) As AdvTextBox
    
    If pValidColor = -1 Then
        Select Case pShowValidityThrough
            Case NoOne, vBackColor
                pValidColor = obj.BackColor
            Case vBorders
                pValidColor = obj.BorderColor
            Case vForeColor
                pValidColor = obj.ForeColor
        End Select
    End If
    If pInvalidColor = -1 Then
        pInvalidColor = defaultInvalidColor
    End If
    
    Set txt = obj
    TextBoxType = txtType
    
    Set Create = Me
    
End Function

Public Function Validate() As Boolean
    
    ColorTextBox pIsValid
    If (Not pIsValid) And (Not pInvalidValueMessage = vbNullString) Then MsgBox pInvalidValueMessage, vbInformation, "Invalid value"
    Validate = pIsValid
    
End Function

' textbox events
Private Sub txt_Change()
    
    If Not pAllowEvents Then Exit Sub
    pAllowEvents = False
    
    Dim valore          As Variant
    
    valore = txt.text
    
    Select Case pTextBoxType
        Case ShortText
            If Not pToCase = Normal Then valore = StrConv(valore, pToCase)
        Case Notes
            If Not pToCase = Normal Then valore = StrConv(valore, pToCase)
        Case Iban
            IsValid = isValidIBAN(valore)
            valore = UCase(valore)
        Case ItalianVatNumber
            IsValid = IsValidItalianVatNumber(valore)
        Case Email
            IsValid = IsValidEmail(valore)
            valore = LCase(valore)
        Case Else
            Dim selectText  As Boolean
            If pFixedFormat Then
                valore = Replace(Replace(valore, ",", vbNullString), ".", vbNullString)
                If valore = vbNullString Then valore = 0
                valore = CDbl(valore)
                Select Case pTextBoxType
                    Case Decimal1Digit
                        valore = valore / 10
                    Case Decimal2Digit
                        valore = valore / 100
                    Case Decimal3Digit
                        valore = valore / 1000
                    Case Decimal4Digit
                        valore = valore / 10000
                    Case Decimal5Digit
                        valore = valore / 100000
                    Case Decimal6Digit
                        valore = valore / 1000000
                End Select
            Else
                valore = Replace(valore, IIf(DecimalSeparator = ",", ".", ","), IIf(DecimalSeparator = ",", ",", "."))
                If Not IsNumeric(valore) Then
                    valore = 0
                    selectText = True
                End If
            End If
            If pEvaluateMinMax Then
                IsValid = (Not valore < pMinValue) And (Not valore > pMaxValue)
            End If
            If pFixedFormat Then valore = Format(valore, pOutputFormat)
    End Select
    
    txt.text = valore
    If selectText Then
        txt.SelStart = 0
        txt.SelLength = Len(CStr(valore))
    End If
    
    pAllowEvents = True
    
End Sub

Private Sub txt_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

    If KeyAscii = 45 Then
        Select Case pTextBoxType
            Case WholeNumber, Decimal1Digit, Decimal2Digit, Decimal3Digit, Decimal4Digit, Decimal5Digit, Decimal6Digit
                txt.text = CDbl(txt.text) * -1
        End Select
    End If
    If Not KeyAscii = 8 Then
        If InStr(1, pAllowedCharacters, Chr(KeyAscii), vbTextCompare) = 0 Then KeyAscii = 0
    End If

End Sub

' validation routines
Private Sub ColorTextBox(validity As Boolean)
    If (Not pShowValidityThrough = NoOne) And (Not txt Is Nothing) Then
        Select Case pShowValidityThrough
            Case vBackColor
                txt.BackColor = IIf(validity, pValidColor, pInvalidColor)
            Case vBorders
                txt.BorderStyle = fmBorderStyleSingle
                txt.BorderColor = IIf(validity, pValidColor, pInvalidColor)
                txt.Width = txt.Width + IIf(pEnlarged, -0.1, 0.1)
                pEnlarged = Not pEnlarged
            Case vForeColor
                txt.ForeColor = IIf(validity, pValidColor, pInvalidColor)
        End Select
    End If
End Sub

Private Function IsValidItalianVatNumber(ByVal str As String) As Boolean
    
    IsValidItalianVatNumber = False
    
    If Not IsNumeric(str) Then Exit Function
    If Not Len(str) = 11 Then Exit Function
    
    Dim X               As Long
    Dim Y               As Long
    Dim z               As Long
    Dim t               As Long
    Dim i               As Long
    Dim c               As Long
    Dim ch              As Variant
    Dim pari            As Boolean
    
    pari = True
    
    For i = 1 To Len(str) - 1
        pari = Not pari
        ch = CLng(Mid(str, i, 1))
        If pari Then
            Y = Y + (ch * 2)
            If ch > 4 Then z = z + 1
        Else
            X = X + ch
        End If
    Next i
    
    t = (X + Y + z) Mod 10
    c = (10 - t) Mod 10
    
    IsValidItalianVatNumber = (c = CLng(Right(str, 1)))
    
End Function

Private Function isValidIBAN(ByVal Iban As String) As Boolean
   
    ' Written by Davide Tonin
    ' Documentation at https://davidetonin.com/code-snippets/how-to-validate-an-iban-with-vba
   
    isValidIBAN = False
   
    Dim LengthByCountry As Long
    Dim ReorderedIBAN   As String
    Dim NumericIBAN     As String
    Dim ch              As String
    Dim i               As Long
    Const Div           As Integer = 97
    Const SepaCountries As String = "AT20,BE16,BG22,CY28,HR21,DK18,EE20,FI18,FR27,DE22,GI23,GR27,GL18,IE22,IS26,FO18,IT27,LV21,LI21,LT20,LU20,MT31,MC27,NO15,NL18,PL28,PT25,GB22,CZ24,SK24,RO24,SM27,SI19,ES24,SE24,CH21,HU28"
   
    If Iban = vbNullString Then Exit Function
   
    'Check if the first 2 characters are letters
    If IsNumeric(Left(Iban, 1)) Or IsNumeric(Mid(Iban, 2, 1)) Then Exit Function
   
    'Get the expected legth by country
    LengthByCountry = InStr(1, SepaCountries, Left(Iban, 2), vbTextCompare)
    If LengthByCountry > 0 Then LengthByCountry = CInt(Mid(SepaCountries, LengthByCountry + 2, 2))
   
    If Len(Iban) <> LengthByCountry Then Exit Function
   
    'Move first 4 characters to right
    ReorderedIBAN = Right(Iban, Len(Iban) - 4) & Left(Iban, 4)
   
    'Loop through every single character in ReorderedIBAN and, if not numeric, return 10 based number from letter using string to store the returned value in place of number
    For i = 1 To Len(ReorderedIBAN)
        ch = Mid(ReorderedIBAN, i, 1)
        If Not IsNumeric(ch) Then
            NumericIBAN = NumericIBAN & CStr(Asc(UCase(ch)) - 55)
        Else
            NumericIBAN = NumericIBAN & CStr(ch)
        End If
    Next i
   
    ch = vbNullString
   
    'Perform primary school style division, digit by digit. I don't need to store the result, only the remainder
    For i = 1 To Len(NumericIBAN)
        ch = ch & Mid(NumericIBAN, i, 1)
        'If is the last character in NumericIBAN I check if remainder is 1 - Only fired once
        If i = Len(NumericIBAN) Then
            isValidIBAN = ((CLng(ch) Mod Div) = 1)
            Exit Function
        End If
        ch = IIf(CLng(ch) < Div, ch, CLng(ch) Mod Div)
    Next i
   
End Function

Private Function IsValidEmail(ByVal emailAddress As String) As Boolean
    
    IsValidEmail = False
    
    Const emailPattern          As String = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
    
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .Pattern = emailPattern
        IsValidEmail = .Test(emailAddress)
    End With
    
End Function

Freeflow · Accepted Answer · 2020-06-11 07:12:22Z

The art of Oop is that you have objects which have a simple, clear and unambiguous roles which can be composed together to achieve the result you want. You don't use objects as a convenient place to hide a pile of disconnected activities.

In the code you provide you have two main issues, collecting a text value and displaying the current validation status, and validating the incoming text value. Let's assume you are validating character by character.

I would have one object (a text gatherer) whose task it is to collect the text input. At initialisation, the text gatherer object would be provided with a validator object.

The text gatherer object provides each character to its validator object. The validator object has two functions.

It indicates if the new character is accepted/not accepted according to the validation criteria.
Triggers a input completed event once an input that matches the desired input has been achieved.

The Validator objects would be written so as to work through an IValidator interface to facilitate intellisense and compiler checking..

For VBA, if there are enumerations and constants that are used across multiple objects I would put these in the relevant interface, or a seperate helper class/module if there are also Methods used by all validator objects.

For the text gatherer object I might also want to split this into an object that just gets text and a second object that displays the current validation status.

Thank you very much! I'm quite new at OOP and this is the kind of suggestions that help to improve. At the moment the abstraction level that I'm confident with is lower than this, but maybe trying:) — DT1
– DT1, Commented Jun 11, 2020 at 11:34
Take a look at the blog articles on the Rubberduck VBA addin website (News). They are very helpful. — Freeflow
– Freeflow, Commented Jun 11, 2020 at 13:18

BZngr · Accepted Answer · 2020-06-11 23:20:34Z

The one class is trying to handle multiple types of textboxes. In this specific case it would seem a better approach to create a class for each textbox type. This keeps code specific to each textbox type very isolated, focused, and much more OO. So, how to get there...

Below is an example refactoring that creates two of the classes needed: DecimalDigitTextBox and EmailTextBox. A standard module AdvTextBoxFactory is introduced to hold the common enums and constants. As the name implies, the module also acts as a Factory to create the specific of textbox validator class that is needed. And, most importantly, an IAdvTextBox interface is defined so that each textbox class can look the same for client code. Hope you find this useful.

IAdvTextBox

Public Function Validate() As Boolean
End Function

Public Property Get TextBoxType() As TextBoxTypes
End Property

Public Property Get MaxValue() As Double
End Property

Public Property Let MaxValue(ByVal value As Double)
End Property

Public Property Get MinValue() As Double
End Property

Public Property Let MinValue(ByVal value As Double)
End Property

Public Property Get FixedFormat() As Boolean
End Property

Public Property Let FixedFormat(ByVal value As Boolean)
End Property

Public Property Get ToCase() As DesiredCase
End Property

Public Property Let ToCase(ByVal value As DesiredCase)
End Property

Public Property Get InvalidValueMessage() As String
End Property

Public Property Let InvalidValueMessage(ByVal value As String)
End Property

Public Property Get IsValid() As Boolean
End Property

Public Property Let IsValid(ByVal value As Boolean)
End Property

Public Property Get ShowValidityThrough() As ValidityProperty
End Property

Public Property Let ShowValidityThrough(ByVal value As ValidityProperty)
End Property

Public Property Get ValidColor() As Long
End Property

Public Property Let ValidColor(ByVal value As Long)
End Property

Public Property Get InvalidColor() As Long
End Property

Public Property Let InvalidColor(ByVal value As Long)
End Property

Public Property Get Enlarged() As Boolean
End Property

Public Property Let Enlarged(ByVal value As Boolean)
End Property

Public Property Get AllowedCharacters() As String
End Property

Public Property Let AllowedCharacters(ByVal value As String)
End Property

AdvTextBoxFactory

Option Explicit

Public Type TAdvTextBox
    TextBoxType As TextBoxTypes
    MaxValue As Double
    MinValue As Double
    FixedFormat As Boolean
    ToCase As DesiredCase
    InvalidValueMessage As String
    IsValid As Boolean
    ShowValidityThrough As ValidityProperty
    ValidColor As Long
    InvalidColor As Long
    AllowedCharacters As String
    outputFormat As String
    DecimalSeparator As String
    Enlarged As Boolean
End Type

Public Enum TextBoxTypes
    ShortText = 0
    Notes = 1
    Iban = 10
    ItalianVatNumber = 11
    Email = 12
    WholeNumber = 20
    Decimal1Digit = 21
    Decimal2Digit = 22
    Decimal3Digit = 23
    Decimal4Digit = 24
    Decimal5Digit = 25
    Decimal6Digit = 26
End Enum

Public Enum DesiredCase
    Normal = 0
    UpperCase = 1
    LowerCase = 2
    ProperCase = 3
End Enum

Public Enum ValidityProperty
    NoOne = 0
    vBorders = 1
    vBackColor = 2
    vForeColor = 3
End Enum

' constants
Public Const numbers                       As String = "0123456789"
Public Const letters                       As String = "abcdefghijklmnopqrstuvwxyz"
Public Const accented                      As String = "èéàòì"
Public Const numberPunctuation             As String = ",."
Public Const otherPunctuation              As String = " !?=_/|-@€+"
Public Const defaultInvalidColor           As Long = &H5F5BDD

Public Function Create(ByVal obj As MSForms.TextBox, _
                    ByVal txtType As TextBoxTypes) As IAdvTextBox
    
    Dim advTxtBox As IAdvTextBox
    
    Select Case txtType
        Case ShortText
            'TODO
        Case Notes
            'TODO
        Case Iban
            'TODO
        Case ItalianVatNumber
            'TODO
        Case Email
            Dim emTxtBox As EmailTextBox
            Set emTxtBox = New EmailTextBox
            emTxtBox.ConnectToTextBox obj
            Set advTxtBox = emTxtBox
        Case WholeNumber
            'TODO
        Case Decimal1Digit, Decimal2Digit, Decimal3Digit, Decimal4Digit, Decimal5Digit, Decimal6Digit
            Dim ddTextBox As DecimalDigitTextBox
            Set ddTextBox = New DecimalDigitTextBox
            ddTextBox.SetupDecimalDigits txtType
            ddTextBox.ConnectToTextBox obj
            Set advTxtBox = ddTextBox
        Case Else
            'throw an error
    End Select
    
    Select Case advTxtBox.ShowValidityThrough
        Case NoOne, vBackColor
            advTxtBox.ValidColor = obj.BackColor
        Case vBorders
            advTxtBox.ValidColor = obj.BorderColor
        Case vForeColor
            advTxtBox.ValidColor = obj.ForeColor
    End Select

    advTxtBox.InvalidColor = defaultInvalidColor

    Set Create = advTxtBox
End Function

DecimalDigitTextBox

Option Explicit

Private WithEvents txt                      As MSForms.TextBox

Implements IAdvTextBox

Private this As TAdvTextBox

Private pDecimalDigitsDivisor As Long

Private pAllowEvents As Boolean

Private Sub Class_Initialize()
    pAllowEvents = True
    this.DecimalSeparator = Application.DecimalSeparator
    this.FixedFormat = True
    this.ShowValidityThrough = NoOne
    this.ToCase = Normal
    this.ValidColor = -1
    this.InvalidColor = -1
    
    'factory updates with correct values in SetupDecimalDigits
    this.TextBoxType = Decimal1Digit
    this.outputFormat = "#,##0.0"
    pDecimalDigitsDivisor = 10
End Sub

Public Sub ConnectToTextBox(txtBox As MSForms.TextBox)
    Set txt = txtBox
    
    this.AllowedCharacters = numbers & IIf(this.FixedFormat, vbNullString, numberPunctuation)
    txt.ControlTipText = "Press ""-"" to change the sign"
    txt.text = 0
End Sub

Public Sub SetupDecimalDigits(ByVal txtType As TextBoxTypes)
    this.TextBoxType = txtType
    Select Case txtType
        Case Decimal1Digit
            this.outputFormat = "#,##0.0"
            pDecimalDigitsDivisor = 10
        Case Decimal2Digit
            this.outputFormat = "#,##0.00"
            pDecimalDigitsDivisor = 100
        Case Decimal3Digit
            this.outputFormat = "#,##0.000"
            pDecimalDigitsDivisor = 1000
        Case Decimal4Digit
            this.outputFormat = "#,##0.0000"
            pDecimalDigitsDivisor = 10000
        Case Decimal5Digit
            this.outputFormat = "#,##0.00000"
            pDecimalDigitsDivisor = 100000
        Case Decimal6Digit
            this.outputFormat = "#,##0.000000"
            pDecimalDigitsDivisor = 1000000
        Case Else
            'throw an error
    End Select
End Sub

Private Sub txt_Change()
    
    If Not pAllowEvents Then Exit Sub
    
    pAllowEvents = False
        
    Dim valore As Variant
    valore = Replace(Replace(txt.text, ",", vbNullString), ".", vbNullString)
    
    If valore = vbNullString Then valore = 0
    
    valore = CDbl(valore) / pDecimalDigitsDivisor
    
    txt.text = CStr(valore)
        
    pAllowEvents = True
    
End Sub

Private Sub txt_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If KeyAscii = 45 Then
            txt.text = CDbl(txt.text) * -1
    End If
    
    If Not KeyAscii = 8 Then
        If InStr(1, this.AllowedCharacters, Chr(KeyAscii), vbTextCompare) = 0 Then KeyAscii = 0
    End If
End Sub

Private Sub ColorTextBox(validity As Boolean)
    If (Not this.ShowValidityThrough = NoOne) And (Not txt Is Nothing) Then
    
        Dim color As Long
        color = IIf(validity, this.ValidColor, this.InvalidColor)
        
        Select Case this.ShowValidityThrough
            Case vBackColor
                txt.BackColor = color
            Case vBorders
                txt.BorderStyle = fmBorderStyleSingle
                txt.BorderColor = color
                txt.Width = txt.Width + IIf(this.Enlarged, -0.1, 0.1)
                this.Enlarged = Not this.Enlarged
            Case vForeColor
                txt.ForeColor = color
        End Select
    End If
End Sub

Private Function IAdvTextBox_Validate() As Boolean
    ColorTextBox this.IsValid
    If (Not this.IsValid) And (Not this.InvalidValueMessage = vbNullString) Then MsgBox this.InvalidValueMessage, vbInformation, "Invalid value"
    IAdvTextBox_Validate = this.IsValid
End Function

Private Property Get IAdvTextBox_TextBoxType() As TextBoxTypes
    IAdvTextBox_TextBoxType = this.TextBoxType
End Property

Private Property Get IAdvTextBox_MaxValue() As Double
    IAdvTextBox_MaxValue = this.MaxValue
End Property

Private Property Let IAdvTextBox_MaxValue(ByVal value As Double)
    this.MaxValue = value
End Property

Private Property Get IAdvTextBox_MinValue() As Double
    IAdvTextBox_MinValue = this.MinValue
End Property

Private Property Let IAdvTextBox_MinValue(ByVal value As Double)
    this.MinValue = value
End Property

Private Property Get IAdvTextBox_FixedFormat() As Boolean
    IAdvTextBox_FixedFormat = this.FixedFormat
End Property

Private Property Let IAdvTextBox_FixedFormat(ByVal value As Boolean)
    this.FixedFormat = value
End Property

Private Property Get IAdvTextBox_ToCase() As DesiredCase
    IAdvTextBox_ToCase = this.ToCase
End Property

Private Property Let IAdvTextBox_ToCase(ByVal value As DesiredCase)
    this.ToCase = value
End Property

Private Property Get IAdvTextBox_InvalidValueMessage() As String
    IAdvTextBox_InvalidValueMessage = this.InvalidValueMessage
End Property

Private Property Let IAdvTextBox_InvalidValueMessage(ByVal value As String)
    this.InvalidValueMessage = value
End Property

Private Property Get IAdvTextBox_IsValid() As Boolean
    IAdvTextBox_IsValid = this.IsValid
End Property

Private Property Let IAdvTextBox_IsValid(ByVal value As Boolean)
    this.IsValid = value
    ColorTextBox this.IsValid
End Property

Private Property Get IAdvTextBox_ShowValidityThrough() As ValidityProperty
    IAdvTextBox_ShowValidityThrough = this.ShowValidityThrough
End Property

Private Property Let IAdvTextBox_ShowValidityThrough(ByVal value As ValidityProperty)
    this.ShowValidityThrough = value
    ColorTextBox IAdvTextBox_IsValid
End Property

Private Property Get IAdvTextBox_ValidColor() As Long
    IAdvTextBox_ValidColor = this.ValidColor
End Property

Private Property Let IAdvTextBox_ValidColor(ByVal value As Long)
    this.ValidColor = value
    ColorTextBox IAdvTextBox_IsValid
End Property

Private Property Get IAdvTextBox_InvalidColor() As Long
    IAdvTextBox_InvalidColor = this.InvalidColor
End Property

Private Property Let IAdvTextBox_InvalidColor(ByVal value As Long)
    this.InvalidColor = value
End Property

Private Property Get IAdvTextBox_Enlarged() As Boolean
    IAdvTextBox_Enlarged = this.Enlarged
End Property

Private Property Let IAdvTextBox_Enlarged(ByVal value As Boolean)
    this.Enlarged = value
    ColorTextBox IAdvTextBox_IsValid
End Property

Private Property Get IAdvTextBox_AllowedCharacters() As String
    IAdvTextBox_AllowedCharacters = this.AllowedCharacters
End Property

Private Property Let IAdvTextBox_AllowedCharacters(ByVal value As String)
    this.AllowedCharacters = value
End Property

EmailTextBox

Option Explicit

Implements IAdvTextBox

Private WithEvents txt                      As MSForms.TextBox

Private this As TAdvTextBox
Private pAllowEvents As Boolean

Private Sub Class_Initialize()
    pAllowEvents = True
    this.DecimalSeparator = Application.DecimalSeparator
    this.FixedFormat = True
    this.ShowValidityThrough = NoOne
    this.ToCase = Normal
    this.ValidColor = -1
    this.InvalidColor = -1
    this.TextBoxType = Email
End Sub

Private Function IsValidEmail(ByVal emailAddress As String) As Boolean
    
    IsValidEmail = False
    
    Const emailPattern          As String = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
    
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .Pattern = emailPattern
        IsValidEmail = .Test(emailAddress)
    End With
    
End Function

Public Sub ConnectToTextBox(txtBox As MSForms.TextBox)
    Set txt = txtBox
End Sub

Private Sub txt_Change()
    
    If Not pAllowEvents Then Exit Sub
    
    pAllowEvents = False
        
    Dim valore As Variant
    valore = txt.text
    
    this.IsValid = IsValidEmail(valore)
    
    valore = LCase(valore)
    
    txt.text = valore
        
    pAllowEvents = True
    
End Sub

Private Sub txt_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If Not KeyAscii = 8 Then
        If InStr(1, this.AllowedCharacters, Chr(KeyAscii), vbTextCompare) = 0 Then KeyAscii = 0
    End If
End Sub

Private Sub ColorTextBox(validity As Boolean)
    If (Not this.ShowValidityThrough = NoOne) And (Not txt Is Nothing) Then
    
        Dim color As Long
        color = IIf(validity, this.ValidColor, this.InvalidColor)
        
        Select Case this.ShowValidityThrough
            Case vBackColor
                txt.BackColor = color
            Case vBorders
                txt.BorderStyle = fmBorderStyleSingle
                txt.BorderColor = color
                txt.Width = txt.Width + IIf(this.Enlarged, -0.1, 0.1)
                this.Enlarged = Not this.Enlarged
            Case vForeColor
                txt.ForeColor = color
        End Select
    End If
End Sub

Private Function IAdvTextBox_Validate() As Boolean
    ColorTextBox this.IsValid
    If (Not this.IsValid) And (Not this.InvalidValueMessage = vbNullString) Then MsgBox this.InvalidValueMessage, vbInformation, "Invalid value"
    IAdvTextBox_Validate = this.IsValid
End Function

Private Property Get IAdvTextBox_TextBoxType() As TextBoxTypes
    IAdvTextBox_TextBoxType = this.TextBoxType
End Property

Private Property Get IAdvTextBox_MaxValue() As Double
    IAdvTextBox_MaxValue = this.MaxValue
End Property

Private Property Let IAdvTextBox_MaxValue(ByVal value As Double)
    this.MaxValue = value
End Property

Private Property Get IAdvTextBox_MinValue() As Double
    IAdvTextBox_MinValue = this.MinValue
End Property

Private Property Let IAdvTextBox_MinValue(ByVal value As Double)
    this.MinValue = value
End Property

Private Property Get IAdvTextBox_FixedFormat() As Boolean
    IAdvTextBox_FixedFormat = this.FixedFormat
End Property

Private Property Let IAdvTextBox_FixedFormat(ByVal value As Boolean)
    this.FixedFormat = value
End Property

Private Property Get IAdvTextBox_ToCase() As DesiredCase
    IAdvTextBox_ToCase = this.ToCase
End Property

Private Property Let IAdvTextBox_ToCase(ByVal value As DesiredCase)
    this.ToCase = value
End Property

Private Property Get IAdvTextBox_InvalidValueMessage() As String
    IAdvTextBox_InvalidValueMessage = this.InvalidValueMessage
End Property

Private Property Let IAdvTextBox_InvalidValueMessage(ByVal value As String)
    this.InvalidValueMessage = value
End Property

Private Property Get IAdvTextBox_IsValid() As Boolean
    IAdvTextBox_IsValid = this.IsValid
End Property

Private Property Let IAdvTextBox_IsValid(ByVal value As Boolean)
    this.IsValid = value
    ColorTextBox this.IsValid
End Property

Private Property Get IAdvTextBox_ShowValidityThrough() As ValidityProperty
    IAdvTextBox_ShowValidityThrough = this.ShowValidityThrough
End Property

Private Property Let IAdvTextBox_ShowValidityThrough(ByVal value As ValidityProperty)
    this.ShowValidityThrough = value
    ColorTextBox IAdvTextBox_IsValid
End Property

Private Property Get IAdvTextBox_ValidColor() As Long
    IAdvTextBox_ValidColor = this.ValidColor
End Property

Private Property Let IAdvTextBox_ValidColor(ByVal value As Long)
    this.ValidColor = value
    ColorTextBox IAdvTextBox_IsValid
End Property

Private Property Get IAdvTextBox_InvalidColor() As Long
    IAdvTextBox_InvalidColor = this.InvalidColor
End Property

Private Property Let IAdvTextBox_InvalidColor(ByVal value As Long)
    this.InvalidColor = value
End Property

Private Property Get IAdvTextBox_Enlarged() As Boolean
    IAdvTextBox_Enlarged = this.Enlarged
End Property

Private Property Let IAdvTextBox_Enlarged(ByVal value As Boolean)
    this.Enlarged = value
    ColorTextBox IAdvTextBox_IsValid
End Property

Private Property Get IAdvTextBox_AllowedCharacters() As String
    IAdvTextBox_AllowedCharacters = this.AllowedCharacters
End Property

Private Property Let IAdvTextBox_AllowedCharacters(ByVal value As String)
    this.AllowedCharacters = value
End Property

Thanks for the answer and the effort! I'm not understanding how an interface works, but I found some articles.. I'll be back as soon as I can understand the logic behind. Thank you! — DT1
– DT1, Commented Jun 11, 2020 at 15:26

Stack Exchange Network

Auto formatting and auto validating TextBox VBA

2 Answers 2

You must log in to answer this question.

Hot Network Questions

Auto formatting and auto validating TextBox VBA

2 Answers 2

You must log in to answer this question.

Related

Hot Network Questions