frmmain.frm

一个资金管理系统的成品 开发环境：VB

     rskjyw.MoveFirst
     m = 0
     Do While Not rskjyw.EOF
        i = 1
        For n = 1 To j - 1
           If DataGrid1.Columns(n).Visible = True Then
               xlSheet.Cells(m + 3, i) = DataGrid1.Columns(n).Value
               i = i + 1
           End If
        Next n
        rskjyw.MoveNext
        m = m + 1
       Loop
       Exit Sub
    End Select
End Sub

Private Sub DataGrid1_Click()
   Dim m_col As Integer
   If rskjyw.RecordCount <> 0 Then
      m_col = DataGrid1.Col
      pzhm = DataGrid1.Columns("1").Text
      Load frmsearch
      frmsearch.Show vbModal
   End If
End Sub

Private Sub Form_Load()
 If userqx = "一般用户" Then
    menukj.Enabled = False
    menubb.Enabled = False
    menudbf.Enabled = False
    menuassist.Enabled = False
    menuuser.Enabled = False
    menuhistory.Enabled = False
 End If
 adorefresh
 If database <> "ysgl" & Left(Date, 4) Then
    MsgBox ("现在已经是" & Left(Date, 4) & "年了，你使用的还是" & Right(database, 4) & "年的数据库，请创建新的数据库！")
 End If
End Sub

Private Sub Dacomglbmdm_Change()
 'Set rs = conn.Execute("select * from yskmlb where dm='" & Left(Dacomdm.Text, 1) & "'")
If Trim(Dacomglbmdm.Text) <> "" Then
  rsgkglbm.Filter = "dm ='" & Trim(Dacomglbmdm.Text) & "'"
  If Not rsgkglbm.EOF Then
    Dacomglbmmc.Text = rsgkglbm.Fields("glbmmc").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub

Private Sub Dacomglbmmc_Change()
If Trim(Dacomglbmmc.Text) <> "" Then
  rsgkglbm.Filter = "glbmmc ='" & Trim(Dacomglbmmc.Text) & "'"
  If Not rsgkglbm.EOF Then
    Dacomglbmdm.Text = rsgkglbm.Fields("dm").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub
Private Sub Dacomyslbdm_Change()
 'Set rs = conn.Execute("select * from yskmlb where dm='" & Left(Dacomdm.Text, 1) & "'")
If Trim(Dacomyslbdm.Text) <> "" Then
  rsyskmlb.Filter = "dm ='" & Trim(Dacomyslbdm.Text) & "'"
  If Not rsyskmlb.EOF Then
    Dacomyslbmc.Text = rsyskmlb.Fields("yslbmc").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub

Private Sub Dacomyslbmc_Change()
If Trim(Dacomyslbmc.Text) <> "" Then
  rsyskmlb.Filter = "yslbmc ='" & Trim(Dacomyslbmc.Text) & "'"
  If Not rsgkglbm.EOF Then
    Dacomyslbdm.Text = rsyskmlb.Fields("dm").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub
Private Sub Dacomyskmdm_Change()
 'Set rs = conn.Execute("select * from yskmlb where dm='" & Left(Dacomdm.Text, 1) & "'")
If Trim(Dacomyskmdm.Text) <> "" Then
  rsyskm.Filter = "dm ='" & Trim(Dacomyskmdm.Text) & "'"
  If Not rsyskm.EOF Then
    Dacomyskmmc.Text = rsyskm.Fields("yskmmc").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub
Private Sub Dacomyskmmc_Change()
If Trim(Dacomyskmmc.Text) <> "" Then
  rsyskm.Filter = "yskmmc ='" & Trim(Dacomyskmmc.Text) & "'"
  If Not rsyskm.EOF Then
    Dacomyskmdm.Text = rsyskm.Fields("dm").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub
Private Sub Dacomgsbmdm_Change()
 'Set rs = conn.Execute("select * from yskmlb where dm='" & Left(Dacomdm.Text, 1) & "'")
If Trim(Dacomgsbmdm.Text) <> "" Then
  rsfygsbm.Filter = "dm ='" & Trim(Dacomgsbmdm.Text) & "'"
  If Not rsfygsbm.EOF Then
    Dacomgsbmmc.Text = rsfygsbm.Fields("gsbmmc").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub
Private Sub Dacomgsbmmc_Change()
If Trim(Dacomgsbmmc.Text) <> "" Then
  rsfygsbm.Filter = "gsbmmc ='" & Trim(Dacomgsbmmc.Text) & "'"
  If Not rsgkglbm.EOF Then
    Dacomgsbmdm.Text = rsfygsbm.Fields("dm").Value
  End If
'  Dacomlbdm.Refresh
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
 conn.Close
End Sub


Private Sub menuhistory_Click()
   Load frmhistory
  frmhistory.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
End Sub

Private Sub menuquit_Click()
  Unload Me
End Sub

Private Sub menuuser_Click()
  Load frmsysuser
  frmsysuser.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  'rsrefresh
End Sub

Private Sub submenudbfbf_Click()
    Dim conn2 As New ADODB.Connection
    Dim rsdevice As New ADODB.Recordset
    Dim str As String
    Dim str2 As String
    On Error GoTo lbErr
    frmbackup.Label1.Caption = "正在备份数据库，请耐心等待！"
    Load frmbackup
    frmbackup.Show
    DoEvents
    Screen.MousePointer = vbHourglass '鼠标显示漏斗为忙的状态
    On Error Resume Next
    conn2.Open connectstring
    str = path & "backup\ysgl" & Date
    conn2.Execute ("use master")
    Set rsdevice = conn.Execute("select * from sysdevices where name='ysglbak'")
    If rsdevice.EOF = True Then
       conn2.Execute ("EXECute sp_addumpdevice 'disk','ysglbak','" & str & ".bak'")
       conn2.Execute ("BACKUP DATABASE [" & database & "] TO [ysglbak] WITH  INIT ,  NOUNLOAD ,  NOSKIP ,  STATS = 10,  NOFORMAT ")
       conn2.Execute ("execute sp_dropdevice 'ysglbak'")
    Else
       conn2.Execute ("BACKUP DATABASE [" & database & "] TO [ysglbak] WITH  INIT ,  NOUNLOAD ,  NOSKIP ,  STATS = 10,  NOFORMAT ")
    End If
    Screen.MousePointer = vbNormal '恢复鼠标的状态
    Unload frmbackup
    MsgBox "数据库备份成功！"
    storewjm ("ysgl" & Date & ".bak")
    rsdevice.Close
    conn2.Close
 Exit Sub
lbErr:
    MsgBox Err.Description
End Sub

Private Sub submenudbfcj_Click()
Dim str1 As String
Dim conn2 As New ADODB.Connection
Dim rsdevice As New ADODB.Recordset
Dim rsprocess As New ADODB.Recordset
Dim str As String
Dim bb As Boolean
Dim i As Integer
Dim j As Integer
'str = "Provider=SQLOLEDB.1;Password=090309;Persist Security Info=True;User ID=cw;Initial Catalog=222;Data Source=cwserver"
If MsgBox("要创建新数据库，请关闭所有使用当前数据库的应用程序！你确认要创建新数据库吗？", vbOKCancel) = vbCancel Then
  Exit Sub
End If
frmbackup.Label1.Caption = "正在创建新数据库，请耐心等待！"
 Load frmbackup
 frmbackup.Show
 DoEvents
Screen.MousePointer = vbHourglass
conn.Close
conn2.Open nowconnectstring
str1 = path & "backup\ysgl" & Date
conn2.Execute ("use master")
str = "select spid from master..sysprocesses where dbid=db_id('" & database & "')"
Set rsprocess = conn2.Execute(str)
Do While rsprocess.EOF = False
      'If Trim(iRe(1)) <> "sleeping" Then
        str = "kill  " & rsprocess(0)
        conn2.Execute str
      'End If
      rsprocess.MoveNext
Loop
rsprocess.Close
    ''恢复数据库
On Error Resume Next
Set rsdevice = conn2.Execute("select * from sysdevices where name='ysgl'")
If rsdevice.EOF = True Then
   str = "execute sp_addumpdevice 'disk','ysgl','" & str1 & ".bak'"
   'str = "execute sp_addumpdevice 'disk','ysgl','D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl2004.bak'"
   conn2.Execute (str)
   str = "BACKUP DATABASE " & database & " TO [ysgl] WITH  INIT ,  NOUNLOAD ,  NOSKIP ,  STATS = 10,  NOFORMAT"
   'str = "BACKUP DATABASE ysgl2004 TO [ysgl] WITH  INIT ,  NOUNLOAD ,  NOSKIP ,  STATS = 10,  NOFORMAT"
   conn2.Execute (str)
   conn2.Execute ("RESTORE FILELISTONLY From ysgl")
'conn2.Execute ("RESTORE DATABASE dgp2   From ysgl   WITH RECOVERY,   Move '" & database & "_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl" & Left(Date, 4) & ".mdf', Move " & database & "_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl2005" & Left(Date, 4) & ".ldf'")
   str = "RESTORE DATABASE " & "ysgl" & Left(Date, 4) & " From ysgl   WITH RECOVERY,   Move '" & database & "_data'  TO  '" & path & "Data\" & "ysgl" & Left(Date, 4) & ".mdf', Move '" & database & "_log' TO '" & path & "data\" & "ysgl" & Left(Date, 4) & ".ldf'"
   'str = "RESTORE DATABASE ysg2008 From ysgl   WITH RECOVERY,   Move 'ysgl2004_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\Data\ysgl2008.mdf', Move 'ysgl2004_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\data\ysgl2008.ldf'"
   conn2.Execute (str)
   conn2.Execute ("execute sp_dropdevice 'ysgl'")
 Else
   str = "BACKUP DATABASE " & database & " TO [ysgl] WITH  INIT ,  NOUNLOAD ,  NOSKIP ,  STATS = 10,  NOFORMAT"
   'str = "BACKUP DATABASE ysgl2004 TO [ysgl] WITH  INIT ,  NOUNLOAD ,  NOSKIP ,  STATS = 10,  NOFORMAT"
   conn2.Execute (str)
   conn2.Execute ("RESTORE FILELISTONLY From ysgl")
'conn2.Execute ("RESTORE DATABASE dgp2   From ysgl   WITH RECOVERY,   Move '" & database & "_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl" & Left(Date, 4) & ".mdf', Move " & database & "_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl2005" & Left(Date, 4) & ".ldf'")
   str = "RESTORE DATABASE " & "ysgl" & Left(Date, 4) & " From ysgl   WITH RECOVERY,   Move '" & database & "_data'  TO  '" & path & "Data\" & "ysgl" & Left(Date, 4) & ".mdf', Move '" & database & "_log' TO '" & path & "data\" & "ysgl" & Left(Date, 4) & ".ldf'"
   'str = "RESTORE DATABASE ysg2008 From ysgl   WITH RECOVERY,   Move 'ysgl2004_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\Data\ysgl2008.mdf', Move 'ysgl2004_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\data\ysgl2008.ldf'"
   conn2.Execute (str)
 End If
 rsdevice.Close
 conn2.Close
 nowconnectstring = connectstring
 i = InStr(nowconnectstring, "ysgl")
 j = Len(nowconnectstring)
 nowconnectstring = Left(nowconnectstring, i - 1) & "ysgl" & Left(Date, 4) & Right(nowconnectstring, j - i + 1 - 8)
 bb = modiini(nowconnectstring, "数据库信息", "数据库", App.path + "\资金管理.ini")
 bb = modiini("ysgl" & Left(Date, 4), "数据库信息", "database", App.path + "\资金管理.ini")
 adorefresh
 conn.Execute ("delete from kjyw")
 Screen.MousePointer = vbNormal '恢复鼠标的状态
 Unload frmbackup
 MsgBox "数据库创建成功！"
End Sub

Private Sub submenudbfhf_Click()
  Dim conn2 As New ADODB.Connection
  Dim rsdevice As New ADODB.Recordset
  Dim rsprocess As New ADODB.Recordset
  Dim str As String
  Load frmhf
  frmhf.Show vbModal
  If wenjm = "" Then
     Exit Sub
  End If
   Dim str2 As String
   str2 = path & "backup\" & wenjm
 On Error GoTo lbErr
 If MsgBox("要还原数据库，请关闭所有使用该数据库的应用程序！你确认要还原数据库吗？", vbOKCancel) = vbCancel Then
   Exit Sub
 End If
 frmbackup.Label1.Caption = "正在恢复数据库，请耐心等待！"
 Load frmbackup
 frmbackup.Show
 DoEvents
 Screen.MousePointer = vbHourglass
 If conn.State = 1 Then
      conn.Close
 End If
 conn2.Open nowconnectstring
 conn2.Execute ("use master")
 str = "select spid from master..sysprocesses where dbid=db_id('" & database & "')"
 Set rsprocess = conn2.Execute(str)
 Do While rsprocess.EOF = False
      'If Trim(iRe(1)) <> "sleeping" Then
        str = "kill  " & rsprocess(0)
        conn2.Execute str
      'End If
      rsprocess.MoveNext
      'iRe.Close
      'iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
 Loop
 rsprocess.Close
    ''恢复数据库
 On Error Resume Next
 Set rsdevice = conn2.Execute("select * from sysdevices where name='ysgl'")
 If rsdevice.EOF = True Then
   conn2.Execute ("execute sp_addumpdevice 'disk','ysgl','" & str2 & "'")
   conn2.Execute ("restore DATABASE [" & database & "] TO [ysgl] ")
'conn2.Execute ("RESTORE DATABASE dgp2   From ysgl   WITH RECOVERY,   Move '" & database & "_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl" & Left(Date, 4) & ".mdf', Move " & database & "_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl2005" & Left(Date, 4) & ".ldf'")
   str = "RESTORE DATABASE " & database & " From ysgl   WITH RECOVERY,   Move '" & database & "_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\Data\ysgl2005.mdf', Move '" & database & "_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\data\ysgl2005.ldf'"
   conn2.Execute (str)
   conn2.Execute ("execute sp_dropdevice 'ysgl'")
 Else
   conn2.Execute ("restore DATABASE [" & database & "] TO [ysgl] ")
'conn2.Execute ("RESTORE DATABASE dgp2   From ysgl   WITH RECOVERY,   Move '" & database & "_data' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl" & Left(Date, 4) & ".mdf', Move " & database & "_log' TO 'D:\Program Files\Microsoft SQL Server\MSSQL\BACKUP\ysgl2005" & Left(Date, 4) & ".ldf'")
 End If
 rsdevice.Close
 rsprocess.Close
 conn2.Close
 Screen.MousePointer = vbNormal '恢复鼠标的状态
 Unload frmbackup
 MsgBox "数据库恢复成功"
 adorefresh
Exit Sub
lbErr:
    MsgBox Err.Description
End Sub

Private Sub submenudbfsz_Click()
  Load frmdbfxz
  frmdbfxz.Show vbModal
  adorefresh
End Sub

Private Sub submenufzglbm_Click()
  Load frmgkglbm
  frmgkglbm.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  rsgkglbm.Requery
End Sub

Private Sub submenufzgsbm_Click()
  Load frmfygsbm
  frmfygsbm.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  rsfygsbm.Requery
End Sub

Private Sub submenufzkm_Click()
  Load frmyskm
  frmyskm.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodc" Or TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  rsyskm.Requery
End Sub

Private Sub submenufzkmlb_Click()
  Load frmkmlb
  frmkmlb.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodc" Or TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  rsyskmlb.Requery
End Sub



Private Sub submenukjadd_Click()
  operatetype = 1
  Load frmywadd
  frmywadd.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodc" Or TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  adorefresh
End Sub

Private Sub submenukjdel_Click()
  operatetype = 3
  Load frmsel
  frmsel.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodc" Or TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
 adorefresh
End Sub

Private Sub submenukjmodi_Click()
  operatetype = 2
  Load frmsel
  frmsel.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodc" Or TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  adorefresh
End Sub

Private Sub submenupzlb_Click()
  Load frmpzlb
  frmpzlb.Show vbModal
  Dim setcontrol As Control
  For Each setcontrol In Me.Controls
    If TypeName(setcontrol) = "Adodc" Or TypeName(setcontrol) = "Adodb" Then
       setcontrol.Refresh
    End If
  Next
  rspzlb.Requery
End Sub