formd44.frm

用VB编写的家庭理财程序

      Width           =   1095
   End
   Begin VB.CommandButton Command1 
      Caption         =   "退 出"
      Height          =   375
      Left            =   7680
      TabIndex        =   2
      Top             =   4800
      Width           =   1095
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   6960
      Top             =   3000
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      BackColor       =   &H008080FF&
      Caption         =   "Label3"
      Height          =   180
      Left            =   5880
      TabIndex        =   5
      Top             =   4440
      Width           =   540
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackColor       =   &H008080FF&
      Caption         =   "Label2"
      Height          =   180
      Left            =   720
      TabIndex        =   1
      Top             =   4440
      Width           =   540
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackColor       =   &H008080FF&
      Caption         =   "Label1"
      Height          =   180
      Left            =   840
      TabIndex        =   0
      Top             =   480
      Width           =   540
   End
End
Attribute VB_Name = "FormD44"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim blnTc As Boolean, strDname As String
Dim intAts As Integer, intRen As Integer, intSts As Integer, t As Byte
Dim strSin As String, strFin As String, strMes As String
Dim No As Byte, intTbs As Integer, arrTmp() As String, arrTbm() As String
Dim s As String, intZhs As Integer, intDrs As Byte
'


Private Sub Form_Load()                                       ' 数据导入
    
   ' SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3                   ' 窗口置前
    Label1.Caption = "请选择："
    Label2.Caption = "Hello !  "
    Label3.Caption = ""
    
 On Error GoTo Erl                                            ' cdlCanccel ???
    strDname = ""
    With CommonDialog1
        .DialogTitle = " 选择 Access 文件"
        .Filter = "*.mdb | *.mdb"
        .CancelError = True
        .ShowOpen
         If Err.Number = 0 Then
            strDname = .FileName
         End If
    End With
    If strDname = "" Then
       blnTc = True
       Exit Sub
    End If
    
    StrSQL = "Select Bh From B_zc Where Zc=1 Order By Xh"
    Set RstMy2 = New Recordset
    RstMy2.Open StrSQL, cnnAce, adOpenKeyset, adLockOptimistic
    If RstMy2.RecordCount > 0 Then
       RstMy2.MoveLast
       k = RstMy2.RecordCount
       intTbs = 14 + k: ReDim arrTbm(intTbs)
          arrTbm(0) = " All Tables"
          arrTbm(1) = " A_tm"
          arrTbm(2) = " A_jh"
          arrTbm(3) = " A_km"
          arrTbm(4) = " A_zl"
          arrTbm(5) = " A_kb"
          arrTbm(6) = " A_ky"
          arrTbm(7) = " A_cp"
          arrTbm(8) = " A_ck"
          arrTbm(9) = " A_jy"
          arrTbm(10) = " B_zc"
          arrTbm(11) = " B_bj"
          arrTbm(12) = " B_ks"
          arrTbm(13) = " B_zl"
          arrTbm(14) = " B_kb"
       RstMy2.MoveFirst
       For i = 1 To k
           arrTbm(i + 14) = " B_" & Right(Trim(RstMy2![Bh]), 4) & "c"     ' k110011.dbf
           RstMy2.MoveNext
       Next
       RstMy2.Close
    End If
    
    k = 0
    
    Exit Sub

Erl:
    blnTc = True

End Sub

Private Sub Form_Activate()
       
    If blnTc = True Then Unload Me: Exit Sub
       
    If myF_ConnT(strDname) = False Then Exit Sub             ' 连接 Access 数据库
    
    t = 0
    For i = 1 To intTbs
        j = myF_ExistT(arrTbm(i))
        If j >= 0 Then                                        ' 备份库中有表
           t = t + 1
           arrTbm(t) = Trim(arrTbm(i))
           Check1(t).Caption = arrTbm(t) & IIf(myF_ExistT(arrTbm(i)) > 0, " *", "")
           Check1(t).Visible = True
        End If
    Next
    intTbs = t
    If intTbs > 1 Then Check1(0).Caption = " 全部数据表": Check1(0).Visible = True

End Sub

Private Sub Check1_Click(Index As Integer)                    ' 选择 Tables
    If Index = 0 Then
       t = IIf(Check1(0).Value = 0, 0, 1)
       For j = 1 To intTbs
           Check1(j).Value = t
       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
       'Command2.Top = 4800
       'Command2.Left = 5160
       Command2.Enabled = False
       Command3.Enabled = True
       intDrs = 0
          For i = 1 To intTbs
              If Check1(i).Value = 1 Then intDrs = intDrs + 1
          Next
          If intDrs = 0 Then Exit Sub
       Frame1.Visible = False
       For i = 1 To intTbs
           If Check1(i).Value = 1 Then
              intRen = myF_ExistT(arrTbm(i))
              If intRen = -1 Then
                 MsgBox "  Access 库中无 " & arrTbm(i) & " 表 ...  ", 48, "  请注意"
              Else
                 If intRen = 0 Then
                    MsgBox "  Access 库中 " & arrTbm(i) & " 表无记录 ... ", 48, "  请注意"
                 Else
                    No = i: Call P_disp
                    Command2.Caption = "导 入"
                    Command2.Enabled = True
                    Command3.Enabled = True
                    Command2.SetFocus
                 End If
              End If
           End If
       Next
    Else                                                      ' 导入
       If Command2.Caption Like "导*" Then
          Call P_save
          If intDrs > 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
          For i = 0 To intTbs
              If Check1(i).Value = 1 Then
                 No = i: Call P_disp
                 If intDrs = 0 Then
                    Command2.Enabled = False
                 Else
                    Command2.Caption = IIf(intAts < 1, "继 续", "导 入")
                    Command2.Enabled = True
                    Command2.SetFocus
                 End If
              End If
          Next
       End If
    End If
End Sub

Private Sub P_disp()
Dim i As Integer
    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
             intAts = RstMy0.RecordCount
          Else
             intAts = 0
          End If
       Else
          intAts = 0
       End If
    strMes = "Access 库 " & arrTbm(No) & " 表"
    If intAts <= 0 Then
       Label1.Caption = strMes & "暂无记录"
       MSFlexGrid1.Visible = False
       Check1(No).Value = 0: intDrs = intDrs - 1
       Command2.Enabled = False
       Label2.Caption = ""
       Exit Sub
    End If
    Label1.Caption = strMes & "有 " & intAts & " 条记录"
    k = RstMy0.Fields.Count
    With MSFlexGrid1
        .Clear
        .Rows = intAts + 1
        .Cols = k + 1
        .Row = 0: .Col = 0: .Text = " No":   .ColWidth(0) = 560
               StrMsg = ""
               For i = 1 To k
                  .Col = i: .Text = " " & RstMy0.Fields(i - 1).Name: .ColWidth(1) = 700
StrMsg = StrMsg & i - 1 & " " & RstMy0.Fields(i - 1).Name & " " & RstMy0.Fields(i - 1) & " - " & RstMy0.Fields(i - 1).Type & vbCrLf
'If i = 3 Then MsgBox i & "-" & j & " " & rstMy0.Fields(i).Name & " " & rstMy0.Fields(i) & " - " & rstMy0.Fields(i).Type
               Next
'MsgBox strMsg
        .Height = 225 * IIf(intAts > 12, 13, intAts + 1) + 90 + 280
      ' .Width = 1900 + IIf(intSts > 12, 270, 0)
         RstMy0.MoveFirst
               For i = 1 To intAts
                  .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               ' 类型对应转换
    s = ""
    Select Case m
           Case 2
                s = "int"                                     ' short
           Case 200
                s = "char(" & n & ")"                         ' text
           Case 4
                s = "numeric(9,2)"                            ' single
    End Select
    F_lxzh = s
End Function

Private Sub P_save()                                          ' 追加记录
    intZhs = 0
    intSts = myF_ExistT(arrTbm(No))
    If intSts >= 0 Then                                       ' 取某表的记录个数
       If intSts > 0 Then
          StrMsg = " 表 " & arrTbm(No) & " 的原有 " & intSts & " 条记录是否清除 ？ "
          If MsgBox(StrMsg, 4 + 32, "  请确认") = 6 Then
             StrSQL = "Delete From " & arrTbm(No)
             cnnAce.Execute StrSQL                            ' 记录全清
          Else
             StrMsg = " 确实要向表 " & arrTbm(No) & " 追加 " & intRen & " 条记录 ？ "
             If MsgBox(StrMsg, 4 + 32, "  请确认") = 6 Then Exit Sub
          End If
       End If
    Else                                                      ' 建立 Table
       ' If M_fucCreat(arrTbm(No)) = -1 Then Exit Sub
       '   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
 On Error GoTo ler
    strSin = ""
        For i = 0 To RstMy0.Fields.Count - 1
            strSin = strSin & IIf(i = 0, "", ",") & RstMy0.Fields(i).Name
        Next
    Label3.Caption = ""
    RstMy0.MoveFirst
strXhp = "0"
    For i = 1 To intAts
        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 i = 2 Then MsgBox i & "-" & j & " " & rstMy0.Fields(j).Name & " " & rstMy0.Fiels(j) & " - " & rstMy0.Fields(j).Type '& "  " & strFin & " " & strSQL: Exit Sub
               Select Case RstMy0.Fields(j).Type
                      Case 2                                             ' short - int
                           strFin = RstMy0.Fields(j).Value
                      Case 4                                             ' single - numeric
                           strFin = RstMy0.Fields(j).Value
                      Case 11                                            ' bit
                           strFin = IIf(RstMy0.Fields(j) = False, 0, 1)
                      Case 200                                           ' text - char
                           strFin = "'" & RstMy0.Fields(j).Value & "'"
                      Case Else
                           strFin = IIf(IsNumeric(RstMy0.Fields(j)) = True, RstMy0.Fields(j), "'" & RstMy0.Fields(j) & "'")
               End Select
               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
'If i > 3 Then Exit Sub
    Next
    If intZhs > 0 Then
       Label2.Caption = "Ok !  完成导入 " & arrTbm(No) & " 共计 " & intZhs & " 条记录"
    End If
    Check1(No).Value = 0: intDrs = intDrs - 1
    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
    intZhs = intZhs - 1
    Resume Next
End Sub

Private Sub Command3_Click()                                   ' Re Select
    Label1.Caption = "请选择："
    Label3.Caption = ""
    MSFlexGrid1.Visible = False
    Frame1.Visible = True
    ' Command2.Top = 4200
    ' Command2.Left = 6480
    Command2.Caption = "确 认"
    Command2.Enabled = False
    Command3.Enabled = False
    For i = 0 To intTbs
        Check1(i).Value = 0
    Next
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
End Sub