administer.frm

我自己编写的个人财务系统,VB语言,用于个人财务统计,可自己初始化财务类别,密码8127!

Im1.Left = 2520
End Sub

Private Sub Label4_Click()
T1(3).Enabled = True
cm7.Enabled = True
cm8.Enabled = True
T1(3).Enabled = True
T1(3).SetFocus

End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
If SSTab1.Tab = 1 Then
    If ok = 1 Then
        Frame4.Visible = True
        ok = 0
    Else
        Exit Sub
    End If

    XJ = 0
    Grade = 1
    Showfile (gradeStore)
    MyOpen rs, "select zw,zw1 from adpw where zw<>null and zw1<>null"
    If Not rs.EOF Then Label8.Caption = rs(0): Label7.Caption = rs(1)
    Text2.Text = "科目:"
End If
End Sub
Private Sub T1_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then SendKeys "{tab}"
If Len(T1(Index).Text) > 5 Then KeyAscii = 0
End Sub


Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    MyOpen rs, "select * from adpw where password='" & Text1.Text & "'"
    If Not rs.EOF Then
        Frame2.Visible = True
        Frame3.Visible = True
        Label6.Enabled = False
        Label6.BackColor = &H8000000F
        Label6.ForeColor = vbBlack
        Text1.Enabled = False
        Text1.BackColor = &H8000000F
        Text1.Text = ""
        ok = 1
        
        MyOpen rs, "select * from pw"
        If rs.EOF Then
            MsgBox "没有帐户，请先创建 ！！！", , "提示"
            Combo1.Locked = True
            T1(2).Locked = True
            Exit Sub
        End If
        Combo1.Clear
        Do While Not rs.EOF
            Combo1.AddItem rs(0)
            rs.MoveNext
        Loop
        Combo1.ListIndex = 0
        rs.MoveFirst
        T1(2).Text = rs(1)
    Else
        MsgBox "密码错误!请重新输入!", vbCritical, "错误!"
        Text1.SetFocus
    End If
    Text1.Text = ""
End If


End Sub

Private Sub tt_Click(Index As Integer)
im(myIndex).BorderStyle = 0

End Sub
Private Sub tt_DblClick(Index As Integer)
tt(Index).Locked = False
tt(Index).ForeColor = vbWhite
tt(Index).BackColor = vbBlue
tt(Index).SelStart = 0
tt(Index).SelLength = 50

myIndex = Index
dblTt = 1

End Sub



Private Sub tt_LostFocus(Index As Integer)

tt(Index).ForeColor = vbBlack
tt(Index).BackColor = vbWhite
tt(Index).Locked = True
If dblTt = 1 Then
    reNamefile (myIndex)
    If RNF = 1 Then Exit Sub
    MyOpen rs, "update program set program='" & tt(myIndex).Text & "' where grade ='" & gradeStore & "" & myIndex + 1 & "'"
    dblTt = 0
End If
If XJ = 1 Then
    reNamefile (Index)
    If RNF = 1 Then Exit Sub
    Tmp = "" & gradeStore & "" & i & ""
    MyOpen rs, "select max(val(keys)) from program "
    On Error GoTo L1:
    Keys = Val(rs(0)) + 1

L2:
    MyOpen rs, "insert into program (grade,program,keys,parents) values ('" & Tmp & "','" & tt(Index).Text & "','" & Keys & "_','" & Parents & "_')"
    XJ = 0
    
End If
Exit Sub
L1:
    Keys = 1: Parents = 0: GoTo L2:
End Sub
Private Sub Showfile(gs As String)
MyOpen rs, "select * from program where grade like '" & gs & "_' order by grade"
i = 0
Do While Not rs.EOF
    tt(i).Text = rs.Fields(1)
    Tmp = rs.Fields(0)
    
    MyOpen RS1, "select * from program where grade like '" & Tmp & "_' order by grade"
    
    If Not RS1.EOF Then
        Line1(i).Visible = True: Line2(i).Visible = True
    Else
        Line1(i).Visible = False: Line2(i).Visible = False
    End If
    
    tt(i).Visible = True
    im(i).Visible = True
    rs.MoveNext
    i = i + 1
Loop
If RS1.State = 1 Then RS1.Close
Tmp = i
Do While Tmp < 9
    Line1(Tmp).Visible = False: Line2(Tmp).Visible = False
    tt(Tmp).Visible = False
    im(Tmp).Visible = False
    Tmp = Tmp + 1
Loop
If Grade > 1 Then
    Frame5.Visible = False
Else
    Frame5.Visible = True
End If

End Sub
Private Sub showGrade(g As Integer)
Do While g > 0
    Tmp = "\" & program(g) & "" + Tmp
    g = g - 1
Loop

Text2.Text = "财务:\" & Tmp & ""
End Sub
Sub reNamefile(id As Integer)
w = tt(id).Text
MyOpen rs, "select * from program where program = '" & tt(id).Text & "'and grade like '" & gradeStore & "[!" & id + 1 & "]'"
If Not rs.EOF Then
    MsgBox "" & tt(id).Text & " 文件重名!重新输入!", , "提示"
    tt(id).SetFocus
    tt(id).ForeColor = vbWhite
    tt(id).BackColor = vbBlue
    tt(id).Locked = False
    tt(id).SelStart = 0
    tt(id).SelLength = 50
    RNF = 1
    Exit Sub
End If
RNF = 0
End Sub
Private Sub Cm3_Click()
Combo1.Locked = False
T1(2).Locked = False
T1(2).Text = ""
Combo1.Text = "填写帐户"
Label2.Caption = "填写密码:"
Combo1.SetFocus
ii = 1
End Sub

Private Sub cm4_Click()
If rs.EOF Then Exit Sub
w = MsgBox("你将删除 " & Combo1.Text & " 的账户!", vbYesNo + vbQuestion + vbDefaultButton2, "提示")
If w = vbNo Then Exit Sub
MyOpen rs, "Delete from pw where name='" & Combo1.Text & "'"

MyOpen rs, "select * from pw"
If rs.EOF Then
    MsgBox "没有帐户，请先创建 ！！！", , "提示"
    Combo1.Clear
    Exit Sub
End If
Combo1.Clear
Do While Not rs.EOF
    Combo1.AddItem rs(0)
    rs.MoveNext
Loop
Combo1.ListIndex = 0
End Sub

Private Sub cm5_Click()
If ii = 1 Then
    If Len(Combo1.Text) = 0 Then MsgBox "输入帐户:", vbCritical, "错误": Combo1.SetFocus: Exit Sub
    If Len(T1(2).Text) = 0 Or Len(T1(2).Text) > 6 Then MsgBox "密码输入有误:", vbCritical, "错误": T1(2).SetFocus: Exit Sub
    MyOpen rs, "select * from pw where name='" & Combo1.Text & "'"
    If rs.EOF Then
    
        rs.AddNew
        rs(0) = Combo1.Text: rs(1) = T1(2).Text
        rs.Update
        ii = 0
        MsgBox "创建成功", , "提示"
        Label2.Caption = "修改密码:"
        Combo1.AddItem Combo1.Text
        Exit Sub
    Else
         MsgBox "帐户已存在，请重填！", , "提示"
         Combo1.SetFocus
         Exit Sub
    End If
    
End If

If rs.EOF Then Exit Sub
If T1(2).Text = "" Then
    MsgBox "请输入密码!", , "提示"
    T1(2).SetFocus
Else
    If Len(T1(2).Text) > 6 Then
        MsgBox "密码不能大于6位!", vbCritical, "错误"
        T1(2).Text = ""
        T1(2).SetFocus
    Else
        MyOpen rs, "select * from pw where name='" & Combo1.Text & "'"
        rs(1) = T1(2).Text
        rs.Update
        MsgBox "你的账户是:" & Combo1.Text & ";密码是:" & T1(2).Text & "", , "成功"
    End If
End If
End Sub

Private Sub cm6_Click()
If cJ = 1 Then
    MyOpen rs, "select * from pw where name='" & Combo1.Text & "'"
    If Not rs.EOF Then T1(2).Text = rs(1)
    Label2.Caption = "修改密码:"
    cJ = 0
    Exit Sub
End If
Combo1.Text = rs(0)
T1(2).Text = rs(1)
End Sub

Private Sub cm7_Click()
MyOpen rs, "select * from adpw"
rs.Update 0, T1(3).Text
MsgBox "管理员密码修改成功!", , "提示"
cm7.Enabled = False
cm8.Enabled = False
T1(3).Enabled = False
End Sub

Private Sub cm8_Click()
T1(3).Text = ""
T1(3).Enabled = False
End Sub

Private Sub Combo1_Click()
MyOpen rs, "select * from pw where name='" & Combo1.Text & "'"
T1(2).Text = rs(1)
Label2.Caption = "修改密码:"
End Sub

Private Sub Command1_Click()
Frame2.Visible = False
Frame3.Visible = False
Text1.Enabled = True
Label6.Enabled = True
Label6.ForeColor = vbWhite
Label6.BackColor = vbBlack
Text1.BackColor = vbBlue
T1(3).Text = ""
rs.Close
XJ = 0
Grade = 1
gradeStore = ""
Frame4.Visible = False
ok = 0
End Sub
Private Sub Label6_Click()

MyOpen rs, "select * from adpw"
If Text1.Text = rs(0) Then
    Frame2.Visible = True
    Frame3.Visible = True
    Label6.Enabled = False
    Label6.BackColor = &H8000000F
    Label6.ForeColor = vbBlack
    Text1.Enabled = False
    Text1.BackColor = &H8000000F
    ok = 1
    
    MyOpen rs, "select * from pw"
    If rs.EOF Then
        MsgBox "没有帐户，请先创建 ！！！", , "提示"
        Exit Sub
    End If

    Do While Not rs.EOF
        Combo1.AddItem rs(0)
        rs.MoveNext
    Loop
    Combo1.ListIndex = 0
    rs.MoveFirst
    T1(2).Text = rs(1)
Else
    MsgBox "密码错误!请重新输入!", vbCritical, "错误!"
    Text1.SetFocus
End If
Text1.Text = ""
End Sub

Private Sub MyOpen1(rs As ADODB.Recordset, Sql As String)
'On Error GoTo l:
    With rs
        If .State = 1 Then .Close
        .CursorLocation = adUseClient
        '.CursorLocation = adUseServer
        .Open Sql, db1, adOpenKeyset, adLockOptimistic
    End With
'Exit Sub
'l:
'MsgBox "操作无效!", vbCritical, "错误"
End Sub

Private Sub Beifeng(Table As String)
MyOpen1 RS2, "select * from beifeng where id like '" & Table & "'"
RS2.MoveFirst
'i = RS2.Fields(3)
'Dim ii As Integer
'ii = 0
Do While Not RS2.EOF
    i = RS2.Fields(3)
    MyOpen1 RS1, "select * from " & RS2.Fields("Table") & ""
    MyOpen rs, "select * from " & RS2.Fields("Table") & ""
    If Not RS1.EOF Then RS1.MoveFirst
    Do While Not RS1.EOF
        RS1.Delete
        RS1.MoveNext
    Loop
    'RS1.Update
    Do While Not rs.EOF
        RS1.AddNew
        For no = 0 To i
            RS1.Fields(no) = rs.Fields(no)
        Next
        'RS1.Fields(4) = rs.Fields(4)
        rs.MoveNext
    Loop
    RS1.Update
    RS2.Fields("dd") = Date
    RS2.MoveNext
    
Loop
MsgBox "备份成功!", , "提示"

End Sub