各种数据验证函数

Public Function InvalidNumeric(txtBox As Object) As Boolean
    On Error Resume Next
    Dim strtext As String
    strtext = txtBox.Text
    If strtext <> "" Then
        If strtext <> "." Then
            If (Not IsNumeric(strtext)) Or (Val(strtext) < 0) Then
                MsgBox "This TextBox can Number", vbInformation, MsgTitle
                InvalidNumeric = True
            Else
                InvalidNumeric = False
            End If
        Else
            InvalidNumeric = False
        End If
    End If
    If InvalidNumeric = True Then
        txtBox.Text = ""
        txtBox.SetFocus
    End If
End Function
Public Function InvalidNumeric1(txtBox As Object) As Boolean
    Dim strtext As String
    strtext = txtBox.Text
    If strtext <> "" Then
        If strtext <> "." Then
            If Not IsNumeric(strtext) Then
                MsgBox "This TextBox Write Number", vbInformation, MsgTitle
                InvalidNumeric1 = True
            Else
                InvalidNumeric1 = False
            End If
        Else
            InvalidNumeric1 = False
        End If
    End If
    If InvalidNumeric1 = True Then
        txtBox.Text = ""
        txtBox.SetFocus
    End If
   
End Function
Public Function InvalidTextLen(txtBox As Object, intLen As Integer) As Boolean
    Dim strtext As String
    strtext = txtBox.Text
    If Len(strtext) > intLen Then
        MsgBox "This TextBox can Only Write 20 ", vbInformation, "Msg"
        strtext = Left(strtext, intLen)
        txtBox.Text = strtext
        InvalidTextLen = True
    Else
        InvalidTextLen = False
    End If
End Function

Public Sub WinClear(frm As Form)
On Error Resume Next
Dim Ctl As Control
For Each Ctl In frm.Controls
    Ctl.Text = ""
Next
End Sub
Public Function DateInvalid(txt As Object)
    On Error Resume Next
    DateInvalid = False
    If txt.Text <> "" Then
        If Not IsDate(txt.Text) Then
            MsgBox "Plaese Write Date ", vbInformation + vbExclamation, MsgTitle
            DateInvalid = True
            txt.Text = ""
            txt.SetFocus
        End If
    End If
End Function
Public Function InvalidTime(txt As Object)
    If txt.Text <> "" Then
        If Not IsDate(txt.Text) Then
            MsgBox "Plaese Write Time ", vbInformation, MsgTitle
            txt.Text = ""
            txt.SetFocus
            Exit Function
        End If
        txt.Text = TimeValue(txt.Text)
    End If
End Function
Public Function FindAndReplaceString(obj As Object, strFind As String, Optional strReplace)
On Error Resume Next
       Dim intPosition As Integer
       'Dim strReplace As String
       If IsMissing(strReplace) Then
          strReplace = strFind
       End If
       If Len(Trim(obj.Text)) = 0 Then
           obj.Text = obj.Text & strReplace
       Else
           intPosition = InStr(1, obj.Text, strFind)
           If intPosition > 0 Then
               obj.Text = Mid(obj.Text, 1, intPosition - 1) & Trim(strReplace) & Mid(obj.Text, intPosition + Len(strFind))
           Else
               obj.Text = obj.Text & strReplace
           End If
       End If
      
End Function
Public Function FindAndReplaceString_S(obj As Object, strFind As String, Optional strReplace) As Integer
On Error Resume Next
       Dim intPosition As Integer
       If IsMissing(strReplace) Then
          strReplace = strFind
       End If
       If Len(Trim(obj.Text)) = 0 Then
           obj.Text = obj.Text & strReplace
       Else
           intPosition = InStr(1, obj.Text, strFind)
           If intPosition > 0 Then
               obj.Text = Mid(obj.Text, 1, intPosition - 1) & Trim(strReplace) & Mid(obj.Text, intPosition + Len(strFind))
           Else
               obj.Text = obj.Text & strReplace
           End If
       End If
       FindAndReplaceString_S = intPosition
      
End Function
Public Function calData(Data() As Single)
    On Error Resume Next

    Dim i As Integer
    Dim Result(0 To 4) As Single
    Dim sngCount As Single, maxData As Single, minData As Single, avgData As Single
    Dim S As Single, N As Integer
    Dim Cv As Single
'    MaxDosage = -1001: MinDosage = 1001
    sngCount = 0: N = UBound(Data) - LBound(Data) + 1
    maxData = Data(LBound(Data)): minData = maxData
    For i = LBound(Data) To UBound(Data)
        sngCount = sngCount + Data(i)
        If Data(i) > maxData Then maxData = Data(i)
        If Data(i) < minData Then minData = Data(i)
    Next
    If N >= 1 Then
        avgData = sngCount / N
        sngCount = 0
        If N > 1 Then
            For i = LBound(Data) To UBound(Data)
                If Data(i) <> -1 Then
                    sngCount = sngCount + (Data(i) - avgData) ^ 2
                End If
            Next
            S = Sqr(sngCount / (N - 1))
            Cv = S / avgData
        End If
    End If
    Result(0) = minData: Result(1) = maxData
    Result(2) = avgData
    Result(3) = S
    Result(4) = Cv
    calData = Result
End Function
Public Function WFormat(Expression, FormatStyle) As Variant
On Error Resume Next
Dim strData As String
Dim myFormat As Variant
Dim i As Integer, j As Integer, k As Integer
Dim intTemp As Integer
Dim rStyle As Integer
 
    rStyle = 1
 
   Select Case rStyle
     Case 1
        strData = Format(Expression, "0.00000000*")
     Case 2
        strData = Format(Expression * 5, "0.00000000*")
     Case 5
        strData = Format(Expression * 2, "0.00000000*")
   End Select
       
        i = InStr(1, FormatStyle, ".", vbTextCompare)
        j = Len(FormatStyle)
        If i <> 0 Then
            k = j - i
        Else
            k = 0
        End If
        intTemp = k
        i = InStr(1, strData, ".", vbTextCompare)
        If i <> 0 And Len(strData) > i + k Then
            j = Mid(strData, i + k + 1, 1)
            If j = 5 And Val(Mid(strData, i + k + 2, Len(strData) - (i + k + 1))) = 0 Then
                If k <> 0 Then
                    j = Mid(strData, i + k, 1)
                Else
                    j = Mid(strData, i - 1, 1)
                End If
                If j Mod 2 = 0 Then
                    If k <> 0 Then
                        myFormat = Left(strData, i + k)
                    Else
                        myFormat = Left(strData, i - 1)
                    End If
                Else
                    Select Case k
                        Case 0
                            myFormat = Format(strData, "0")
                        Case 1
                            myFormat = Format(strData, "0.0")
                        Case 2
                            myFormat = Format(strData, "0.00")
                        Case 3
                            myFormat = Format(strData, "0.000")
                        Case 4
                            myFormat = Format(strData, "0.0000")
                        Case Else
                            myFormat = Format(strData, "0.00000")
                    End Select
                End If
            Else
                Select Case k
                    Case 0
                        myFormat = Format(strData, "0")
                    Case 1
                        myFormat = Format(strData, "0.0")
                    Case 2
                        myFormat = Format(strData, "0.00")
                    Case 3
                        myFormat = Format(strData, "0.000")
                    Case 4
                        myFormat = Format(strData, "0.0000")
                    Case Else
                        myFormat = Format(strData, "0.00000")
                End Select
            End If
        Else
            Select Case k
                Case 0
                    myFormat = Format(strData, "0")
                Case 1
                    myFormat = Format(strData, "0.0")
                Case 2
                    myFormat = Format(strData, "0.00")
                Case 3
                    myFormat = Format(strData, "0.000")
                Case 4
                    myFormat = Format(strData, "0.0000")
                Case Else
                    myFormat = Format(strData, "0.00000")
            End Select
        End If
    
    Select Case rStyle
     Case 1
        WFormat = myFormat
     Case 2
        If intTemp <> 0 Then
        WFormat = Format(myFormat / 5, "0." & String(intTemp, 0))
        Else
         WFormat = Format(myFormat / 5, "0")
        End If
     Case 5
        If intTemp <> 0 Then
        WFormat = Format(myFormat / 2, "0." & String(intTemp, 0))
        Else
         WFormat = Format(myFormat / 2, "0")
        End If
   End Select
End Function

Public Function MFormat(Expression, FormatStyle, RestrictStyle) As Variant
On Error Resume Next
Dim strData As String
Dim myFormat As Variant
Dim i As Integer, j As Integer, k As Integer
Dim intTemp As Integer
Dim rStyle As Integer
  If IsMissing(RestrictStyle) Then
    rStyle = 1
  Else
    rStyle = RestrictStyle
  End If
   Select Case rStyle
     Case 1
        strData = Format(Expression, "0.00000000*")
     Case 2
        strData = Format(Expression * 5, "0.00000000*")
     Case 5
        strData = Format(Expression * 2, "0.00000000*")
   End Select
       
        i = InStr(1, FormatStyle, ".", vbTextCompare)
        j = Len(FormatStyle)
        If i <> 0 Then
            k = j - i
        Else
            k = 0
        End If
        intTemp = k
        i = InStr(1, strData, ".", vbTextCompare)
        If i <> 0 And Len(strData) > i + k Then
            j = Mid(strData, i + k + 1, 1)
            If j = 5 And Val(Mid(strData, i + k + 2, Len(strData) - (i + k + 1))) = 0 Then
                If k <> 0 Then
                    j = Mid(strData, i + k, 1)
                Else
                    j = Mid(strData, i - 1, 1)
                End If
                If j Mod 2 = 0 Then
                    If k <> 0 Then
                        myFormat = Left(strData, i + k)
                    Else
                        myFormat = Left(strData, i - 1)
                    End If
                Else
                    Select Case k
                        Case 0
                            myFormat = Format(strData, "0")
                        Case 1
                            myFormat = Format(strData, "0.0")
                        Case 2
                            myFormat = Format(strData, "0.00")
                        Case 3
                            myFormat = Format(strData, "0.000")
                        Case 4
                            myFormat = Format(strData, "0.0000")
                        Case Else
                            myFormat = Format(strData, "0.00000")
                    End Select
                End If
            Else
                Select Case k
                    Case 0
                        myFormat = Format(strData, "0")
                    Case 1
                        myFormat = Format(strData, "0.0")
                    Case 2
                        myFormat = Format(strData, "0.00")
                    Case 3
                        myFormat = Format(strData, "0.000")
                    Case 4
                        myFormat = Format(strData, "0.0000")
                    Case Else
                        myFormat = Format(strData, "0.00000")
                End Select
            End If
        Else
            Select Case k
                Case 0
                    myFormat = Format(strData, "0")
                Case 1
                    myFormat = Format(strData, "0.0")
                Case 2
                    myFormat = Format(strData, "0.00")
                Case 3
                    myFormat = Format(strData, "0.000")
                Case 4
                    myFormat = Format(strData, "0.0000")
                Case Else
                    myFormat = Format(strData, "0.00000")
            End Select
        End If
    
    Select Case rStyle
     Case 1
        MFormat = myFormat
     Case 2
        MFormat = Format(myFormat / 5, "0." & String(intTemp + 1, "0"))
     Case 5
        MFormat = Format(myFormat / 2, "0." & String(intTemp + 1, "0"))
   End Select
End Function