formd4.frm

用VB编写的家庭理财程序

 On Error Resume Next
 
    StrSQL = "Select id,name,info,crdate From sysObjects " & _
             " Where Left(name,2)='A_' or Left(name,2)='B_'" & _
             " Order By name"
    Set RstMy2 = New Recordset
    RstMy2.Open StrSQL, cnnAce, adOpenKeyset, adLockOptimistic
    If RstMy2.RecordCount > 0 Then
       RstMy2.MoveLast
       intTbs = RstMy2.RecordCount:  ReDim arrTbm(intTbs)
       k = 0
       RstMy2.MoveFirst
       For i = 1 To intTbs
           arrTbm(i) = RstMy2![Name]
           j = myF_ExistT(arrTbm(i))
           If j >= 0 Then
              k = k + 1
              arrTbm(k) = Trim(arrTbm(i))
              Check1(k).Caption = arrTbm(k) & IIf(j > 0, " *", "")
              Check1(k).Visible = True
           End If
           RstMy2.MoveNext
       Next
       RstMy2.Close
    End If
    intTbs = k
    
    If intTbs > 1 Then Check1(0).Caption = " 全部数据表": Check1(0).Visible = True
    binTs = True

End Sub
    
Private Sub P_bak()

'   cnnAce.Close
'   cnnAce.Cancel

    strFm1 = "C:\Program Files\Microsoft SQL Server\MSSQL\Data\Sm01_Data.MDF"
    strFm2 = "D:\Bysj\Sjx_Server\Sjx_new\Sjx6\Sm01_Data2.MDF"
    FileCopy strFm1, strFm2
    strFm1 = "C:\Program Files\Microsoft SQL Server\MSSQL\Data\Sm01_Log.LDF"
    strFm2 = "D:\Bysj\Sjx_Server\Sjx_new\Sjx6\Sm01_Log.LDF"
    FileCopy strFm1, strFm2
    
    MsgBox "ok !"

End Sub
    

Private Sub Check1_Click(Index As Integer)                           ' 选择 Tables
    If Index = 0 Then
       k = IIf(Check1(0).Value = 0, 0, 1)
       For j = 1 To intTbs
           Check1(j).Value = k
       Next
       Command2.Enabled = IIf(Check1(0).Value = 0, False, True)
       If Command2.Enabled = True Then Command2.SetFocus
    Else
       Command2.Enabled = False
       For j = 0 To intTbs
           If Check1(j).Value = 1 Then Command2.Enabled = True: Exit For
       Next
    End If
End Sub

Private Sub Command2_Click()                                         ' 选择 确认/备份
    If Command2.Caption Like "确*" Then
       strDname = ""
       On Error GoTo Erl
       With CommonDialog1
           .DialogTitle = "  请确定备份文件名"
           .Filter = "*.mdb | *.mdb"
           .CancelError = True
           .ShowOpen
            If Err.Number = 0 Then                                   ' cdlCanccel
               strDname = .FileName
            End If
       End With
       If strDname = "" Then Exit Sub
       
       intBfs = 0
          For i = 0 To intTbs
              If Check1(i).Value = 1 Then intBfs = intBfs + 1
          Next
          If intBfs = 0 Then Exit Sub
       Frame1.Visible = False
       If Trim(Dir(strDname)) = "" Or Err Then                       ' 建立文件夹
         ' Call P_MkDir(strDpath)
          Set MyDb = CreateDatabase(strDname, dbLangGeneral)         ' 建立数据库
          MyDb.Close
       End If
       If myF_ConnT(strDname) = False Then Exit Sub                 ' 连接数据库
       For i = 1 To intTbs
           If Check1(i).Value = 1 Then
              No = i: Call P_disp
              If intRs0 = 0 Then
                 If intBfs = 0 Then
                    Command2.Enabled = False
                    Command3.Enabled = True
                    Command3.SetFocus
                 Else
                    Command2.Caption = "继 续"
                    Command2.Enabled = True
                    Command2.SetFocus
                 End If
              Else
                 Command2.Caption = "备 份"
                 Command2.Enabled = True
                 Command2.SetFocus
              End If
              Exit For
           End If
       Next
       Command2.Top = 5280
       Command2.Left = 6720
       Command3.Enabled = True
    Else                                                             ' 备份
       Command2.Enabled = False
       Command3.Enabled = False
       If Command2.Caption Like "备*" Then
          If binTs = True Then
             For i = 1 To intTbs
                 If Check1(i).Value = 1 Then
                    No = i: Call P_save
                    Exit For
                 End If
             Next
             If intBfs > 0 Then
                Command2.Caption = "继 续"
                Command2.Enabled = True
                Command2.SetFocus
             Else                                                    ' Ok 备份
                Command2.Caption = "确 认"
                Command2.Enabled = False
                Command1.SetFocus
             End If
             Command3.Enabled = True
          Else                                                       ' 连续备份
             Command2.Enabled = False
             Label1.Caption = ""
             MSFlexGrid1.Visible = False
             For n = 1 To intTbs
                 If Check1(n).Value = 1 Then
'MsgBox n & " " & Check1(n).Caption
                    Label3.Caption = n & " 备份: " & Check1(n).Caption
                    No = n: Call P_save
                 End If
             Next
             Command3.Enabled = True: Command3.SetFocus
          End If
       Else                                                          ' 继续
          For i = 1 To intTbs
              If Check1(i).Value = 1 Then
                 No = i: Call P_disp
                 If intBfs = 0 Then
                    Command2.Enabled = False
                 Else
                    Command2.Caption = IIf(intRs0 < 1, "继 续", "备 份")
                    Command2.Enabled = True
                    Command3.Enabled = True
                    Command2.SetFocus
                 End If
                 Exit For
              End If
          Next
       End If
    End If
    Exit Sub
Erl:

End Sub

Private Sub P_disp()
    StrSQL = "Select * From " & arrTbm(No)
    Set RstMy0 = New Recordset
    RstMy0.Open StrSQL, cnnAce, adOpenKeyset, adLockOptimistic
       If RstMy0.RecordCount >= 0 Then
          If RstMy0.RecordCount > 0 Then
             RstMy0.MoveLast
             intRs0 = RstMy0.RecordCount
          Else
             intRs0 = 0
          End If
       Else
          intRs0 = 0
       End If
    strMes = "现 " & arrTbm(No) & " 表"
    If intRs0 <= 0 Then
       Label1.Caption = strMes & "暂无记录"
       MSFlexGrid1.Visible = False
       Check1(No).Value = 0: intBfs = intBfs - 1
       Command2.Enabled = False
       Label2.Caption = ""
       Exit Sub
    End If
    Label1.Caption = strMes & "有 " & intRs0 & " 条记录"
    k = RstMy0.Fields.Count
    With MSFlexGrid1
        .Clear
        .Rows = intRs0 + 1
        .Cols = k + 1
        .Row = 0: .Col = 0: .Text = " No":   .ColWidth(0) = 450
               For i = 1 To k
                  .Col = i: .Text = " " & RstMy0.Fields(i - 1).Name: .ColWidth(1) = 600
               Next
        .Height = 225 * IIf(intRs0 > 10, 11, intRs0 + 1) + 90 + 280
       ' .Width = 1900 + IIf(intRs1 > 10, 270, 0)
         RstMy0.MoveFirst
               For i = 1 To intRs0
                  .Row = i
                  .Col = 0: .Text = Str(i) & " "
                   For j = 1 To k
                      .Col = j: .Text = " " & RstMy0.Fields(j - 1)
                   Next
                   RstMy0.MoveNext
               Next i
       .Visible = True
    End With
    Label2.Caption = "Hello !  "
    Command2.Enabled = True
    Command2.SetFocus
End Sub

Function F_lxzh(m As Byte, n As Long) As String
    Select Case m
           Case 3
                s = "short"                       ' int
           Case 11
                s = "bit"                         ' bit
           Case 129
                s = "text(" & n & ")"             ' char
           Case 131
                s = "single"                      ' numeric
           Case 133
                s = "text(" & n & ")"             ' date    ???
           Case 205
                s = "text(5)"                     ' image   ???
           Case Else
                s = "text(" & n & ")"             ' char
    End Select
    F_lxzh = s
End Function

Private Sub P_save()                                                 ' 追加记录
 
    Check1(No).Value = 0: intBfs = intBfs - 1
    intZhs = 0
 
 If binTs = True Then
    
    intRs1 = myF_ExistT(arrTbm(No))                                ' 取某表的记录个数
    If intRs1 >= 0 Then
       If intRs1 > 0 Then
          StrMsg = "  Access 表 " & arrTbm(No) & " 的原有 " & intRs1 & " 条记录是否清除 ？ "
          If MsgBox(StrMsg, 4 + 32, "  请确认") <> 6 Then Exit Sub
             StrSQL = "Delete From " & arrTbm(No)
             cnnAce.Execute StrSQL                                   ' 记录全清
          End If
       Else                                                          ' 建立 Table
          strSin = " ( "
          For i = 0 To RstMy0.Fields.Count - 1
              strSin = strSin & IIf(i = 0, "", ",") & RstMy0.Fields(i).Name & " " & _
                       F_lxzh(RstMy0.Fields(i).Type, RstMy0.Fields(i).DefinedSize)
'MsgBox i & " " & rstMy0.Fields(i).Type & " " & rstMy0.Fields(i).DefinedSize
          Next
              strSin = strSin & " ) "
              StrSQL = "CREATE TABLE " & arrTbm(No) & strSin
          cnnAce.Execute StrSQL
       End If
 
 Else                                                                 ' 连续备份
 
    intRs1 = myF_ExistT(arrTbm(No))                                 ' 取某表的记录个数
    If intRs1 >= 0 Then
       StrSQL = "Delete From " & arrTbm(No)                           ' 记录全清
       cnnAce.Execute StrSQL
    Else                                                              ' 建立 Table
       strSin = " ( "
          For i = 0 To RstMy0.Fields.Count - 1
              strSin = strSin & IIf(i = 0, "", ",") & RstMy0.Fields(i).Name & " " & _
                       F_lxzh(RstMy0.Fields(i).Type, RstMy0.Fields(i).DefinedSize)
          Next
       strSin = strSin & " ) "
       StrSQL = "CREATE TABLE " & arrTbm(No) & strSin
       cnnAce.Execute StrSQL
    End If
 
 End If
 
 On Error GoTo ler
    strSin = ""
        For i = 0 To RstMy0.Fields.Count - 1
            strSin = strSin & IIf(i = 0, "", ",") & RstMy0.Fields(i).Name
'MsgBox i & rstMy0.Fields(i).Name & rstMy0.Fields(i).Type
        Next
    If binTs = True Then Label3.Caption = ""
    RstMy0.MoveFirst
    For i = 1 To intRs0
        If binTs = True Then Label3.Caption = i
        If Trim(RstMy0.Fields(0)) = "" Then
           MsgBox "  原 " & arrTbm(No) & " 表第 " & i & " 条记录有误，略过 ...  ", 48, "  请注意"
        Else
           StrMsg = ""
           For j = 0 To RstMy0.Fields.Count - 1
               If IsNull(RstMy0.Fields(j).Value) = True Then
                  strFin = 0                                     '  ???
               Else
                  Select Case RstMy0.Fields(j).Type
                         Case 3                                                             ' int
                              strFin = RstMy0.Fields(j)
                         Case 11                                                            ' bit
                              strFin = IIf(RstMy0.Fields(j) = False, 0, 1)
                         Case 129                                                           ' char
                              If IsNull(RstMy0.Fields(j)) Then
                                 strFin = "' '"
                              Else
                                 strFin = Trim(RstMy0.Fields(j).Value)
                                 strFin = "'" & IIf(strFin = "", " ", strFin) & "'"
                              End If
                         Case 131                                                            ' numeric
                              strFin = RstMy0.Fields(j)
                         Case 133
                              strFin = Format(RstMy0.Fields(j), "yyyy.mm.dd")
                              strFin = "'" & IIf(strFin = "", " ", strFin) & "'"
                         Case 205
                              strFin = "' '"                  ' ??? image
                         Case Else
                              strFin = RstMy0.Fields(j)
                  End Select
               End If
               StrMsg = StrMsg & IIf(j = 0, "", ",") & strFin
           Next
           StrSQL = "INSERT INTO " & arrTbm(No) & " (" & strSin & ") VALUES(" & StrMsg & ")"
           cnnAce.Execute StrSQL
           intZhs = intZhs + 1
        End If
        RstMy0.MoveNext
    Next
    If intZhs > 0 Then
       Label2.Caption = "Ok !  已将" & strMes & "备份到 " & strDname   ' & " ( 共计 " & intZhs & " 条记录 ) ..."
    End If
    If binTs = True Then Label3.Caption = ""
Exit Sub
ler:
    MsgBox "  原 " & arrTbm(No) & " 表第 " & i & " 条记录有误，略过 ...  ", 48, "  请注意"
'   MsgBox i & "-" & j & " " & rstMy0.Fields(j).Type & "  " '& rstMy0.Fields(j).Name & rstMy0.Fields(j) & "  " & strFin & " " & strSQL: Exit Sub
    MsgBox StrSQL
    intZhs = intZhs - 1
Exit Sub
    Resume Next
End Sub

Private Sub Command3_Click()                                   ' Re Select
    MSFlexGrid1.Visible = False
    Label1.Caption = "请选择："
    Frame1.Visible = True
    Label2.Caption = "Hello !  "
    Command2.Top = 4680
    Command2.Left = 8040
    Command2.Caption = "确 认"
    Command2.Enabled = False
    Command3.Enabled = False
    For i = 0 To intTbs
        Check1(i).Value = 0
    Next
End Sub

Private Sub P_MkDir(strPat As String)                          ' 建立子文件夹
On Error Resume Next
   Call MkDir(strPat)
End Sub

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
 On Error Resume Next
    RstMy0.Close: Set RstMy0 = Nothing                         ' 关闭记录集，释放对象
    RstMy1.Close: Set RstMy1 = Nothing
    cnnAce.Close: Set cnnAce = Nothing
    MyDb.Close:   Set MyDb = Nothing
End Sub

Private Sub Option1_Click()
    binTs = IIf(Option1 = True, True, False)
End Sub

Private Sub Option2_Click()
    binTs = IIf(Option2 = True, False, True)
End Sub