Visual Basic for Applications/Input Boxes

Summary This code block contains an input box function. It includes a number of fairly common validation routines that are selected within the main procedure. VBA Code 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 See Also External Links