module1.bas

用VB编写的家庭理财程序

         StrMsg = Format(c, "yyyy.mm.dd")
            k = Len(StrMsg)
            If k < 6 Or k > 10 Then
               MsgBox "  出生日期格式有误，请修改 ...  ", 48, "  请注意"
               F_rqgs = " "
               Exit Function
            End If
            If k < 10 Then
               m = ""
               For i = 1 To k
                   s = Mid(StrMsg, i, 1)
                   m = m & IIf(s = ".", "/", s)
               Next
               StrMsg = Format(m, "yyyy.mm.dd")
            End If
         F_rqgs = StrMsg
End Function
  
Function mF_rqgs(s As String) As String                            ' 日期格式
Dim c As String, d As String
    l = Len(s)                                                     ' "yyyy.mm.dd"
    If l = 0 Then mF_rqgs = "": Exit Function
    If l = 6 And IsDate(s) = True Then
       If Mid(s, 3, 1) = "." And Mid(s, 5, 1) = "." Then
          c = Right(s, 1)
          d = Left(s, 2)                                           ' 00.1.1
          s = Mid(s, 4, 1)
          If IsNumeric(c) And IsNumeric(s) And (Val(d) > 0 Or d = "00") Then
             mF_rqgs = IIf(d > 40, "19", "20") & d & ".0" & s & ".0" & c
             Exit Function
          End If
       End If
    End If
    If l <> 3 And IsDate(s) = True Then
       mF_rqgs = Format(s, "yyyy.mm.dd"): Exit Function
    End If
    mF_rqgs = "False"                                              ' 非标准
    Select Case l
           Case 2
                If Val(s) >= 10 Then
                   mF_rqgs = IIf(s > 40, "19", "20") & s
                End If
           Case 4
                If Val(s) >= 1000 Then
                   mF_rqgs = s
                Else                                               ' 56.7
                   If Mid(s, 3, 1) = "." Then
                      c = Right(s, 1)
                      If IsNumeric(c) Then
                         d = Left(s, 2)
                         mF_rqgs = IIf(d > 40, "19", "20") & d & ".0" & c
                      End If
                   End If
                End If
           Case 5                                                  ' 56.07
                If Mid(s, 3, 1) = "." Then
                   c = Right(s, 2)
                   If IsNumeric(c) And Val(c) < 13 Then
                      d = Left(s, 2)
                      mF_rqgs = IIf(d > 40, "19", "20") & d & "." & c
                   End If
                End If
           Case 6                                                  ' 44.5.6
                If Mid(s, 3, 1) = "." And Mid(s, 5, 1) = "." Then
                   c = Right(s, 1)
                   d = Left(s, 2)
                   s = Mid(s, 4, 1)
                   If IsNumeric(c) And IsNumeric(d) And IsNumeric(s) Then
                      mF_rqgs = IIf(d > 40, "19", "20") & d & ".0" & s & ".0" & c
                   End If
                Else
                   If Mid(s, 5, 1) = "." Then                      ' 2000.5
                      c = Right(s, 1)
                      d = Left(s, 4)
                      If IsNumeric(c) And IsNumeric(d) Then
                         mF_rqgs = d & ".0" & c
                      End If
                    End If
                End If
           Case 7
                If Mid(s, 3, 1) = "." And Val(Left(s, 2)) >= 1 Then
                   d = Left(s, 2)
                   If Mid(s, 5, 1) = "." Then                      ' 58.5.12
                      c = Right(s, 2)
                      s = Mid(s, 4, 1)
                      If Val(c) >= 1 And Val(s) >= 1 Then
                         mF_rqgs = IIf(d > 40, "19", "20") & d & ".0" & s & "." & c
                      End If
                   Else
                      If Mid(s, 6, 1) = "." Then                   ' 58.01.1
                         c = Right(s, 1)
                         s = Mid(s, 4, 2)
                         If Val(c) >= 1 And Val(s) >= 1 Then
                            mF_rqgs = IIf(d > 40, "19", "20") & d & "." & s & ".0" & c
                         End If
                      End If
                   End If
                Else
                   If Mid(s, 5, 1) = "." Then                      ' 1972.10
                      c = Right(s, 2)
                      d = Left(s, 4)
                      If Val(c) >= 1 And Val(c) >= 1 Then
                         mF_rqgs = s
                      End If
                   End If
                End If
           Case 8
                If Mid(s, 3, 1) = "." And Mid(s, 6, 1) = "." Then  ' 95.07.08
                   c = Right(s, 2)
                   d = Left(s, 2)
                   s = Mid(s, 4, 2)
                   If Val(c) >= 1 And Val(d) >= 1 And Val(s) >= 1 Then
                      mF_rqgs = IIf(d > 40, "19", "20") & d & "." & s & "." & c
                   End If
                Else                                               ' 1988.5.1
                   If Mid(s, 5, 1) = "." And Mid(s, 7, 1) = "." Then
                      c = Right(s, 1)
                      d = Left(s, 4)
                      s = Mid(s, 6, 1)
                      If Val(c) >= 1 And Val(d) >= 1000 And Val(s) >= 1 Then
                         mF_rqgs = d & ".0" & s & ".0" & c
                      End If
                   End If
                End If
           Case 9
                d = Left(s, 4)
                If d > 1000 Then
                   If Mid(s, 5, 1) = "." And Mid(s, 7, 1) = "." Then      ' 1988.5.12
                      c = Right(s, 2)
                      s = Mid(s, 6, 1)
                      If Val(c) >= 1 And Val(s) >= 1 Then
                         mF_rqgs = d & ".0" & s & "." & c
                      End If
                   Else
                      If Mid(s, 5, 1) = "." And Mid(s, 8, 1) = "." Then   ' 1988.05.1
                         c = Right(s, 1)
                         s = Mid(s, 6, 2)
                         If Val(c) >= 1 And Val(s) >= 1 Then
                            mF_rqgs = d & "." & s & ".0" & c
                         End If
                      End If
                   End If
                End If
           Case 10
                If Mid(s, 5, 1) = "." And Mid(s, 8, 1) = "." Then
                   d = Left(s, 4)
                   c = Right(s, 2)                                 ' 1988.05.12
                   s = Mid(s, 6, 2)
                   If Val(d) >= 1000 And Val(s) >= 1 And Val(c) >= 1 Then
                      mF_rqgs = d & "." & s & "." & c
                   End If
                End If
    End Select
    If mF_rqgs = "False" Then
       StrMsg = "  日期应按下列格式输入: " & vbCrLf & vbCrLf & _
                "  yyyy.mm.dd 或 yy-mm-dd 或 yy/mm/dd ...  " & vbCrLf
       MsgBox StrMsg, 48, "  请注意"
    End If
End Function
   
Function myF_ifmt(m As Integer, n As Integer) As String
    myF_ifmt = Space(n - Len(Str(m))) & Str(m)
End Function

Private Sub myP_delay(n As Integer)                                ' 延迟 n 秒
    Dim x, y As Integer
       x = Val(Right(Time(), 2))
    Do While True
       y = Val(Right(Time(), 2))
       If y - x >= n Then Exit Do
    Loop
End Sub
 
Private Sub myP_DeleTable(strTName As String)                      ' 删除表
    strTName = UCase(Trim(strTName))
    If Len(strTName) > 0 Then
       If myF_ExistT("strTName") = True Then
          Set MyDb2 = OpenDatabase(Db_Name2)
          StrSQL = "DROP TABLE " & strTName
          cnnTce.Execute StrSQL, , adCmdText
          MsgBox "  " & strTName & " is already deleted ...  ", 48, "  Ok !"
       Else
          MsgBox "  Not Tabel " & strTName & " !   ", 48, "  Error"
       End If
    Else
       MsgBox "  !?  Tabel Name  ", 48, "  Error !"
    End If
End Sub