module1.bas

用VB编写的家庭理财程序

Attribute VB_Name = "Module1"
 
Option Explicit                                                    ' ★☆△～√
 
    Public Const StrDir = "\Mdb"                                   ' 相对路径
    Public Const Db_Name2 = "\Db_T.mdb"                            ' 数据库
    Public Db_fN2 As String
    
    Public cnnTce As Connection, MyDb2 As Database, MyTb2 As TableDef
        
    Public MyRs0 As Recordset, strT0 As String, N0 As Integer      ' 记录集、表名及记录个数
    Public MyRs1 As Recordset, StrT1 As String, N1 As Integer
    Public MyRs2 As Recordset, StrT2 As String, N2 As Integer
    Public MyRs3 As Recordset, StrT3 As String, N3 As Integer
    Public MyRs4 As Recordset, StrT4 As String, N4 As Integer
    Public MyRs5 As Recordset, StrT5 As String, N5 As Integer
    
    Public strRq As String, StrCrq As String
    Public StrDms As String, StrUse As String, StrKls As String, StrUjb As String, BlnKlf As Boolean
    Public StrShm As String, StrGum As String, StrDwm As String
    Public StrSQL As String, StrMsg As String, StrTms As String, c As String, s As String
    Public StrPa1 As String, StrPa2 As String, StrPa3 As String
    Public i As Integer, j As Integer, k As Integer, zs As Integer
    Public l As Byte, m As Byte, n As Byte, u As Byte
    Public blnTc As Boolean

'   Declare Function flashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInsert As Long) As Long

    Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
            ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'
        
Sub Main()
    ' F_Start.Show       'frmSplash.Show       ' FormA5.Show   '
End Sub

Public Sub myP_mkDir(MyDir As String)                              ' 建立文件夹
 On Error Resume Next
    Call MkDir(MyDir)
End Sub

Function myF_ConnT(strDname As String) As Boolean                  ' ActivetX + Access
 On Error GoTo T_error
    Set cnnTce = New Connection                                    ' 建立一个连接  数据库名 T
        cnnTce.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Persist Security Info=False;" & _
                    "Data Source=" & strDname
    myF_ConnT = True
    Exit Function
T_error:
    MsgBox "  " & strDname & " 连接失败，无法导入数据 .... ", 48, "  很抱歉"
    myF_ConnT = False
    MsgBox "  " & "Error # " & Str$(Err.Number) & vbCrLf & vbCrLf & "  " & Err.Description
End Function

Function myF_ExistT(strTName As String) As Integer                 ' 判断表 strTName 的存在
 On Error GoTo O_Err
    StrSQL = "Select * From " & strTName
    Set MyRs1 = New Recordset
    MyRs1.Open StrSQL, cnnTce, adOpenKeyset, adLockOptimistic
    If MyRs1.EOF = True And MyRs1.BOF = True Then
       myF_ExistT = 0                                              ' 空表
    Else
       MyRs1.MoveLast
       myF_ExistT = MyRs1.RecordCount                              ' 返回记录数
    End If
    MyRs1.Close: Set MyRs1 = Nothing
    Exit Function
O_Err:
    myF_ExistT = -1                                                ' 无表
End Function

Function myF_ChekTRec(strTName As String) As Integer               ' 检查表记录
    zs = myF_ExistT(strTName)
    If zs < 1 Then                                                 ' 无记录
       Select Case strTName
              Case "T_rc"
                   StrMsg = "  应先处理比赛日程，请选 < A2.会期确定 >  ....  "
              Case "T_gm"
                   StrMsg = "  应先处理赛会分组，请选 < A3.竞赛分组 >  ....  "
              Case "T_dw"
                   StrMsg = "  应先确定参赛单位，请选 < A4.单位安排 >  ....  "
              Case "T_pm"
                   StrMsg = "  应先处理比赛项目，请选 < A5.项目安排 >  ....  "
              Case "T_bm"
                   StrMsg = "  应先录入比赛报名，请选 < A7.报名输入 >  ....  "
              Case "T_md"
                   StrMsg = "  应先录入比赛报名，请选 < A7.报名输入 >  ....  "
              Case "T_shsj"
                   StrMsg = "  应先处理比赛时间排定，请选 < B4.比赛时间 >  ....  "
              Case "T_xlst"
                   StrMsg = "  应先进行资格赛顺序抽签排定，请选 < B7.分组抽签 >  ....  "
              Case "V_Jscj"
                   StrMsg = "  应先进行资格赛顺序抽签排定，请选 < B7.分组抽签 >  ....  "
              Case "V_Fjcj"
                   StrMsg = "  很抱歉，尚无同分决赛成绩记录  ....  "
       End Select
    End If
    myF_ChekTRec = zs
End Function

Function myP_cton(s As String) As Integer                          ' 汉字转为数字（全能项数）
    Dim intSn As Integer
        If s Like "*一*" Then intSn = 1
        If s Like "*二*" Then intSn = 2
        If s Like "*三*" Then intSn = 3
        If s Like "*四*" Then intSn = 4
        If s Like "*五*" Then intSn = 5
        If s Like "*六*" Then intSn = 6
        If s Like "*七*" Then intSn = 7
        If s Like "*八*" Then intSn = 8
        If s Like "*九*" Then intSn = 9
        If s Like "*十*" Then intSn = 10
    myP_cton = intSn
End Function

Function myP_Ntoc(n As Integer) As String                          ' 数字转为汉字（全能项数）
    Dim strSz As String
        If n = 1 Then strSz = "一"
        If n = 2 Then strSz = "二"
        If n = 3 Then strSz = "三"
        If n = 4 Then strSz = "四"
        If n = 5 Then strSz = "五"
        If n = 6 Then strSz = "六"
        If n = 7 Then strSz = "七"
        If n = 8 Then strSz = "八"
        If n = 9 Then strSz = "九"
        If n = 10 Then strSz = "十"
    myP_Ntoc = strSz
End Function

Function myF_ctod(ys As String) As Date                            ' 字符串 -> 日期类型
 On Error GoTo ProcError
    Dim i, m, n As String
        m = ""
    For i = 1 To Len(ys)
        n = Mid(ys, i, 1)
        m = m & IIf(n = "." Or n = ",", "-", n)                    ' 规范化例: "2002-02-02"
    Next
    myF_ctod = CDate(m)
ProcError:
    Exit Function
End Function

Function myF_ctos(ymd As String) As String                         ' 日期字符串规格化
    ymd = Trim(ymd)
 On Error GoTo ProcError
    Dim i, m, n As String
        m = ""
    For i = 1 To Len(ymd)
        n = Mid(ymd, i, 1)
        m = m & IIf(n = "." Or n = "," Or n = "/", "-", n)         ' 规范化例: "2002-02-02"
    Next
    myF_ctos = Format(CDate(m), "yyyy.mm.dd")                      ' 字符串规范化例: "2002.02.02"
ProcError:
    Exit Function
End Function

Function myF_Len(s As String) As Integer                           ' 返回字符串长度 ( 折合为英文字符位数 )
Dim i, l, n As Integer, m As String
    l = Len(s)
    n = 0
    If l > 0 Then
       For i = 1 To l
           m = Mid(s, i, 1)
           n = n + IIf(Asc(m) < 0, 2, 1)
       Next
    End If
    myF_Len = n
End Function

Function myF_Left(Zfc As String, Jqc As Byte) As String            ' 左起截取字符
Dim m As Byte, n As Byte, x As Byte
Dim c As String, s As String
    n = 0
    s = ""
    For x = 1 To Len(Zfc)
        c = Mid(Zfc, x, 1)
        m = IIf(Asc(c) < 0, 2, 1)
        If m + n > Jqc Then Exit For
        s = s & c
        n = n + m
    Next
    myF_Left = s
End Function

Function F_rqgs(c As String) As String                             ' 日期规格化
         If c = "" Then
            F_rqgs = " "
            Exit Function
         End If
         Dim m, s As String