menu42.frm

大学毕业的课题,可能比较简单一点,入门的人可以

VERSION 5.00
Begin VB.Form winmenu42 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "数据备份模块"
   ClientHeight    =   4140
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7170
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   4140
   ScaleWidth      =   7170
   Begin VB.Frame Frame1 
      BorderStyle     =   0  'None
      Height          =   3060
      Left            =   480
      TabIndex        =   0
      Top             =   480
      Width           =   6015
      Begin VB.DriveListBox Drive1 
         Height          =   300
         Left            =   720
         TabIndex        =   3
         Top             =   2440
         Width           =   1575
      End
      Begin VB.CommandButton Command1 
         Caption         =   "确    认"
         Height          =   375
         Left            =   3000
         TabIndex        =   2
         Top             =   2400
         Width           =   1215
      End
      Begin VB.CommandButton Command2 
         Caption         =   "退   出"
         Height          =   375
         Left            =   4320
         TabIndex        =   1
         Top             =   2400
         Width           =   1215
      End
      Begin VB.Label Label1 
         Caption         =   $"menu42.frx":0000
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   14.25
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   1455
         Left            =   360
         TabIndex        =   5
         Top             =   720
         Width           =   5415
      End
      Begin VB.Label Label2 
         Caption         =   "数 据 备 份 模 块"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   24
            Charset         =   134
            Weight          =   400
            Underline       =   -1  'True
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C00000&
         Height          =   495
         Left            =   1200
         TabIndex        =   4
         Top             =   120
         Width           =   4215
      End
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000005&
      BorderWidth     =   3
      X1              =   360
      X2              =   360
      Y1              =   360
      Y2              =   3600
   End
   Begin VB.Line Line4 
      BorderColor     =   &H80000006&
      BorderWidth     =   3
      X1              =   6615
      X2              =   6615
      Y1              =   360
      Y2              =   3600
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000005&
      BorderWidth     =   3
      X1              =   360
      X2              =   6580
      Y1              =   360
      Y2              =   360
   End
   Begin VB.Line Line3 
      BorderColor     =   &H80000006&
      BorderWidth     =   3
      X1              =   360
      X2              =   6600
      Y1              =   3600
      Y2              =   3600
   End
   Begin VB.Shape Shape2 
      BorderColor     =   &H80000003&
      FillColor       =   &H00808080&
      FillStyle       =   0  'Solid
      Height          =   255
      Left            =   600
      Top             =   3615
      Width           =   6255
   End
   Begin VB.Shape Shape1 
      BorderColor     =   &H00C0C0C0&
      FillColor       =   &H00808080&
      FillStyle       =   0  'Solid
      Height          =   3135
      Left            =   6630
      Top             =   720
      Width           =   255
   End
End
Attribute VB_Name = "winmenu42"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim bdkk As Database
Dim bdktab As Recordset
Dim bf As Database
Dim bftab As Recordset
Dim lsls As String
Private Sub mkdir1()
On Error GoTo b:
MkDir (lsls + "\数据备份")
b:
End Sub
Private Sub mkfile()
End Sub

Private Sub Command1_Click()
On Error GoTo bb:
lsls = Mid(Drive1.Drive, 1, 2)
'If Dir(lsls + "\数据备份") = "" Then MkDir (lsls + "\数据备份")
mkdir1
ff = Date
fdate = LTrim(RTrim(Str$(Year(ff)))) + LTrim(RTrim(Str$(Month(ff)))) + LTrim(RTrim(Str$(Day(ff))))
bb = "\" + fdate + ".mdb"
If Dir$(lsls + "\数据备份" + bb) <> "" Then
   GoTo ee:
Else
   'MkDir lsls + "\数据备份"
   Dim mydb As Database
   Dim mywo As Workspace
   Set mywo = DBEngine.Workspaces(0)
   Set mydb = mywo.CreateDatabase(lsls + "\数据备份" + bb, dbLangGeneral, dbversion03)
   Dim gcd As TableDef
   Dim gcdfield(1 To 15) As Field
   Set gcd = mydb.CreateTableDef("gcd")
   Set gcdfield(1) = gcd.CreateField("hzdw", dbText, 30)
   Set gcdfield(2) = gcd.CreateField("hzname", dbText, 12)
   Set gcdfield(3) = gcd.CreateField("cx", dbText, 8)
   Set gcdfield(4) = gcd.CreateField("ch", dbText, 20)
   Set gcdfield(5) = gcd.CreateField("wzname", dbText, 20)
   Set gcdfield(6) = gcd.CreateField("mz", dbText, 8)
   Set gcdfield(7) = gcd.CreateField("pz", dbText, 8)
   Set gcdfield(8) = gcd.CreateField("zj", dbText, 8)
   Set gcdfield(9) = gcd.CreateField("sby", dbText, 12)
   Set gcdfield(10) = gcd.CreateField("modi", dbText, 1)
   Set gcdfield(11) = gcd.CreateField("lsh", dbText, 8)
   Set gcdfield(12) = gcd.CreateField("rq", dbText, 10)
   Set gcdfield(13) = gcd.CreateField("ttime", dbText, 5)
   Set gcdfield(14) = gcd.CreateField("fhname", dbText, 12)
   Set gcdfield(15) = gcd.CreateField("bz", dbText, 50)
  For i = 1 To 15
       gcd.Fields.Append gcdfield(i)
   Next i
   mydb.TableDefs.Append gcd
End If
Set chb = mydb.CreateTableDef("chb")
Set gcdfield(1) = chb.CreateField("ch", dbText, 20)
chb.Fields.Append gcdfield(1)
mydb.TableDefs.Append chb
'第三个表,层数表
mydb.Close
ee:
Set bdkk = OpenDatabase(App.Path + "\bdk.mdb")
Set bdktab = bdkk.OpenRecordset("select * from gcd order by val(lsh)")
Set bf = OpenDatabase(lsls + "\数据备份" + bb)

bf.Execute "delete * from gcd"
bf.Execute "delete * from chb"
Do While Not bdktab.EOF
   zh1 = bdktab("cx")
   If bdktab("hzdw") <> Empty Then zh2 = bdktab("hzdw") Else zh2 = " "
   If bdktab("hzname") <> Empty Then zh3 = bdktab("hzname") Else zh3 = " "
   If bdktab("ch") <> Empty Then zh4 = bdktab("ch") Else zh4 = " "
   If bdktab("wzname") <> Empty Then zh5 = bdktab("wzname") Else zh5 = " "
   If bdktab("mz") <> Empty Then zh6 = bdktab("mz") Else zh6 = " "
   If bdktab("pz") <> Empty Then zh7 = bdktab("pz") Else zh7 = " "
   If bdktab("zj") <> Empty Then zh8 = bdktab("zj") Else zh8 = " "
   If bdktab("sby") <> Empty Then zh9 = bdktab("sby") Else zh9 = " "
   If bdktab("modi") <> Empty Then zh10 = bdktab("modi") Else zh10 = " "
   If bdktab("lsh") <> Empty Then zh11 = bdktab("lsh") Else zh11 = " "
   If bdktab("rq") <> Empty Then zh12 = bdktab("rq") Else zh12 = " "
   If bdktab("ttime") <> Empty Then zh13 = bdktab("ttime") Else zh13 = " "
   If bdktab("fhname") <> Empty Then zh14 = bdktab("fhname") Else zh14 = " "
   If bdktab("bz") <> Empty Then zh15 = bdktab("bz") Else zh15 = " "
   bf.Execute "insert into gcd (cx,hzdw,hzname,ch,wzname,mz,pz,zj,sby,modi,lsh,rq,ttime,fhname,bz) values ('" + zh1 + "','" + zh2 + "','" + zh3 + "','" + zh4 + "','" + zh5 + "','" + zh6 + "','" + zh7 + "','" + zh8 + "','" + zh9 + "','" + zh10 + "','" + zh11 + "','" + zh12 + "','" + zh13 + "','" + zh14 + "','" + zh15 + "')"
   bdktab.MoveNext
Loop
Set bdktab = bdkk.OpenRecordset("select * from chb")
Do While Not bdktab.EOF
   zh1 = bdktab("ch")
   bf.Execute "insert into chb (ch) values ('" + zh1 + "') "
   bdktab.MoveNext
Loop
MsgBox "数据备份已经完成！"
Exit Sub
bb:
MsgBox "发生读写错误,请更换 磁盘或退出重试！", vbCritical + vbExclamation, "图书管理系统"
Set bdkk = Nothing
Set bf = Nothing
End Sub

Private Sub Command2_Click()
mainboot.Picture1.Visible = True
mainboot.menunum = "nothing"
Unload Me
End Sub

Private Sub Form_Load()
winmenu42.Left = 1800
winmenu42.Top = 1500
winmenu42.Width = 7335
winmenu42.Height = 4545
'Shape5.Left = 11
'Shape5.Top = 11
'Shape5.Width = 6114
'Shape5.Height = 2864
             Frame1.Visible = True
'             Shape1.Top = 30
'             Shape1.Left = 30
'             Shape1.Width = 4875
'             Shape1.Height = 2515
            
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
mainboot.menunum = "nothing"
'mainboot.Picture1.Visible = True
End Sub