Visual Basic for Applications/输入框
此代码块包含一个输入框函数。它包括许多在主过程中选择的相当常见的验证例程。
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