Input Boxes

Option Explicit

Sub TestGetAnInput()
    'run to test input box functions
    
    Dim vR As Variant, bC As Boolean
    
    If GetAnInput(vR, bC) Then
        MsgBox vR
    ElseIf bC = True Then MsgBox "Cancel or too many attempts"
    Else
        MsgBox "Input must be an integer"
    End If
    
End Sub

Function GetAnInput(vRet As Variant, bCancel As Boolean) As Boolean
    '================================================================================
    'Input box function - gets an input from user with choice of validation, or none.
    'Returns value in vRet and funcion True, or bCancel = true and function False.
    'With bUseValidation = True, loops until success, cancel, or 3 failed attempts.
    'With bUseValidation = False, returns first entry without validation.
    'Enable chosen validation function below.
    '================================================================================
    
    Dim Reply As Variant, bValidated As Boolean, n As Long, bUseValidation As Boolean
    Dim sMsg As String, sTitle As String, sDefault As String
    Dim nS As Integer, nE As Integer
        
    'set assignments
    sMsg = "Enter an integer..."
    sTitle = "Input box..."
    sDefault = "1234567890"
    n = 1
    nS = 32: nE = 126 'printing chara set 32-126
    bUseValidation = False 'use validation at all?
    
    Do  'get user input
        Reply = InputBox(sMsg, sTitle, sDefault)
        
        'test if validation needed
        If bUseValidation = False Then
            bValidated = True
            Exit Do
        End If

        'control number of attempts
        If n >= 3 Then 'set attempt limit here
            Exit Do
        End If
        n = n + 1
        
        'add validation by removing comment on one function call
        ' ========================================================
        '            ENABLE ONLY ONE VALIDATION FUNCTION
        ' ========================================================
        ' If IsNumeric(Reply) Then bValidated = True
        ' If IsAnInteger(Reply) Then bValidated = True
        ' If IsADate(Reply) Then bValidated = True
        ' If IsLikeCustomFormat(Reply) Then bValidated = True
        ' If IncludesAscRange(Reply, nS, nE) Then bValidated = True
        ' If ExcludesAscRange(Reply, nS, nE) Then bValidated = True
        ' If IsAllInAscRange(Reply, nS, nE) Then bValidated = True
        '=========================================================
    
    Loop Until bValidated = True Or Reply = ""
    
    'transfers
    If bValidated Then
        vRet = Reply       'got one
        GetAnInput = True
    ElseIf Reply = "" Then 'cancelled
        bCancel = True
    Else                   'too many tries
        bCancel = True
    End If
    
End Function

Function IsAnInteger(ByVal vIn As Variant) As Boolean
    'returns true if input contains an integer

    'check if numeric
    'numeric excludes dates and booleans
    If IsNumeric(vIn) Then
           'check long version against original
           If vIn = CLng(vIn) Then
               IsAnInteger = True
           End If
    End If

End Function

Function IsADate(ByVal vIn As Variant) As Boolean
    'returns true if input contains a date

    'check if date
    If IsDate(vIn) Then
        IsADate = True
    End If

End Function

Function IsAllInAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if entire string lies in asci parameter range
    
    Dim n As Long, sS As String, sAccum As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'accumulate all validated charas
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                sAccum = sAccum & sS
        End Select
    Next n
     
    If Len(sAccum) = Len(vIn) Then
        IsAllInAscRange = True
    End If

End Function

Function IncludesAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if any part of string lies in asci parameter range
    
    Dim n As Long, sS As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'early exit for first inclusion found
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                'found - so exit
                IncludesAscRange = True
                Exit Function
        End Select
    Next n
     
End Function

Function ExcludesAscRange(ByVal vIn As Variant, nS As Integer, _
                                  nE As Integer) As Boolean
    'returns true if input does not contain any part of asci parameter range
    
    Dim n As Long, sS As String, sAccum As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    '================================================================
    ' Character Set (0-127) ASCI Values            Assignments
    '================================================================
    '48 To 57                                 'integers 0-9
    '65 To 90                                 'capital letters A-Z
    '97 To 122                                'lower case letters a-z
    '33 To 47, 58 To 64,91 To 96, 123 To 126  'printing symbols
    '0 To 7, 11 To 12, 14 To 31, 127          'not Windows supported
    '32                                       'space character
    '8, 9, 10, 13                             'vbBack,vbTab,vbLf,vbCr
    '=================================================================
       
    'early exit for first inclusion found
    For n = 1 To Len(vIn)
        sS = Mid(CStr(vIn), n, 1)
        Select Case Asc(sS)
            Case nS To nE 'parameters
                'found - so exit
                sAccum = sAccum & sS
        End Select
    Next n
     
    If sAccum = "" Then
        ExcludesAscRange = True
    End If

End Function

Function IsLikeCustomFormat(ByVal vIn As Variant) As Boolean
    'returns true if input pattern is like internal pattern
    
    Dim sPattern As String
    
    'check vIn
    If CStr(vIn) = "" Then
        Exit Function
    End If
    
    'specify the pattern - see help for Like operator
    sPattern = "CAT###-[a-z][a-z]#" 'for example CAT123-fg7
    
    'test the pattern against input
    IsLikeCustomFormat = vIn Like sPattern
     
End Function