backup.frm

酒店系统源码。为了学习和 研究软件内含的设计思想和原理

VERSION 5.00
Begin VB.Form BACKUP 
   Caption         =   "数据备份"
   ClientHeight    =   3450
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5490
   Icon            =   "backup.frx":0000
   ScaleHeight     =   3450
   ScaleWidth      =   5490
   StartUpPosition =   2  '屏幕中心
   Begin VB.ComboBox Combo1 
      Height          =   300
      Left            =   4140
      TabIndex        =   5
      Text            =   "Combo1"
      Top             =   1740
      Visible         =   0   'False
      Width           =   1275
   End
   Begin VB.CommandButton Command2 
      Caption         =   "取 消"
      Height          =   375
      Left            =   4200
      TabIndex        =   4
      Top             =   960
      Width           =   975
   End
   Begin VB.CommandButton Command1 
      Caption         =   "备 份"
      Height          =   375
      Left            =   4200
      TabIndex        =   3
      Top             =   420
      Width           =   975
   End
   Begin VB.DriveListBox Drive1 
      Height          =   300
      Left            =   180
      TabIndex        =   1
      Top             =   420
      Width           =   3615
   End
   Begin VB.DirListBox Dir1 
      Height          =   2400
      Left            =   180
      TabIndex        =   0
      Top             =   840
      Width           =   3615
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "请选择备份目录:"
      Height          =   315
      Left            =   240
      TabIndex        =   2
      Top             =   120
      Width           =   1575
   End
End
Attribute VB_Name = "BACKUP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim DATBAK As Database
Dim RECBACKUP As Recordset
Dim BFPATH As String
Public BFFILE As String
Public DISKS As Integer
Public Function BFILEEXISTS(SFILE As String) As Boolean
    If Dir$(SFILE) <> "" Then BFILEEXISTS = True Else BFILEEXISTS = False
End Function

Private Sub Command1_Click()
    On Error GoTo LOCALERR
    RECBACKUP.FindFirst "ID = 13"
    If Not RECBACKUP.NoMatch Then
       BFPATH = RECBACKUP("CS")
       If left(BFPATH, 1) = "'" Then BFPATH = right(BFPATH, Len(BFPATH) - 1)
       If right(BFPATH, 1) = "'" Then BFPATH = left(BFPATH, Len(BFPATH) - 1)
       If Not BFILEEXISTS(BFPATH) Then
          MsgBox "指定的数据文件未找到,无法继续!", vbCritical, "错误"
          Exit Sub
       End If
       Else
         MsgBox "系统数据内部错误,无法继续!", vbCritical, "错误"
         Unload BACKUP
    End If
    RECBACKUP.FindFirst "ID = 4"
    If Not RECBACKUP.NoMatch Then
       RECBACKUP.Edit
       If UCase(left(Dir1.Path, 1)) = "A" Then RECBACKUP("CS") = ".Set MaxDiskSize=1024000" _
          Else RECBACKUP("CS") = ".Set MaxDiskSize=CDROM"
       RECBACKUP.Update
       Else
         MsgBox "系统数据内部错误,无法继续!", vbCritical
         Unload BACKUP
    End If
    RECBACKUP.FindFirst "ID = 10"
    If Not RECBACKUP.NoMatch Then
       RECBACKUP.Edit
       If UCase(left(Dir1.Path, 1)) = "A" Then
          RECBACKUP("CS") = ".Set CabinetNameTemplate='BACKUP\" + Trim(RECBACKUP("FILE")) + "'"
          Else
            If right(Dir1.Path, 1) = "\" Then RECBACKUP("CS") = ".Set CabinetNameTemplate='" & Dir1.Path & Trim(RECBACKUP("FILE")) & "'" _
               Else RECBACKUP("CS") = ".Set CabinetNameTemplate='" & Dir1.Path & "\" & Trim(RECBACKUP("FILE")) & "'"
       End If
       RECBACKUP.Update
       Else
         MsgBox "系统数据内部错误,无法继续!", vbCritical
         Unload BACKUP
    End If
    NFILE = FreeFile
    Open App.Path & "\BACKUP.DDF" For Output As #NFILE
    RECBACKUP.MoveFirst
    Do While Not RECBACKUP.EOF()
       Print #NFILE, RECBACKUP("CS")
       RECBACKUP.MoveNext
    Loop
    Close #NFILE
    ChDrive left(App.Path, 2)
    ChDir App.Path
    If BFILEEXISTS("BACKUP\*.*") Then Kill "BACKUP\*.*"
    If BFILEEXISTS("SETUP.INF") And BFILEEXISTS("SETUP.RPT") Then Kill "SETUP.*"
    If BFILEEXISTS("BACKUP.WC_") Then Kill "BACKUP.WC_"
    NFILE = FreeFile
    Open App.Path & "\BACKUP.BAT" For Output As #NFILE
    If UCase(left(Dir1.Path, 1)) <> "A" Then
       Print #NFILE, "MAKECAB /F BACKUP.DDF>BACKUP.WC_"
       Else
         Print #NFILE, "MAKECAB /L BACKUP /F BACKUP.DDF>BACKUP.WC_"
    End If
    Close #NFILE
    Shell "BACKUP.BAT", vbHide
    Load JDT
    JDT.Show vbModal
    If UCase(left(Dir1.Path, 1)) <> "A" Then
'       If BFILEEXISTS("BACKUP.DDF") Then Kill "BACKUP.DDF"
'       If BFILEEXISTS("BACKUP.BAT") Then Kill "BACKUP.BAT"
       If BFILEEXISTS("SETUP.INF") And BFILEEXISTS("SETUP.RPT") Then Kill "SETUP.*"
       If BFILEEXISTS("BACKUP.WC_") Then Kill "BACKUP.WC_"
       If JDT.STRERROR = "" Then
          MsgBox "恭喜!您的数据已安全备份...", vbInformation + vbOKOnly, "提示信息"
       End If
       GoTo LOCALEXIT
    End If
    SNEXTFILE = Dir$("BACKUP\*.*")
    Dim DD As String
    While SNEXTFILE <> ""
          Combo1.AddItem (Trim(SNEXTFILE))
          SNEXTFILE = Dir$
    Wend
    DISKS = 1
    Do While DISKS <= Combo1.ListCount
       BFFILE = Combo1.List(DISKS - 1)
COPY:
        SFBF = MsgBox("此次备份共需" + CStr(Combo1.ListCount) + "张空白高密软盘," + Chr(13) + "请准备好备份盘,并填写好标签。" _
               + Chr(13) + Chr(13) + "Please Insert Disk:#" + CStr(DISKS), vbInformation + vbOKCancel, "提示信息")
        If SFBF = vbOK Then
           If BFILEEXISTS("A:\*.*") Then
              SFSC = MsgBox("A:盘中有文件,是否换盘再试?", vbQuestion + vbYesNo, "提示信息")
              If SFSC = vbYes Then GoTo COPY Else GoTo LOCALEXIT
           End If
           Load BFJDT
           BFJDT.Show vbModal
           Else
             GoTo LOCALEXIT
        End If
        DISKS = DISKS + 1
    Loop
    If BFILEEXISTS("BACKUP.DDF") Then Kill "BACKUP.DDF"
    If BFILEEXISTS("BACKUP.BAT") Then Kill "BACKUP.BAT"
    If BFILEEXISTS("SETUP.INF") And BFILEEXISTS("SETUP.RPT") Then Kill "SETUP.*"
    If BFILEEXISTS("BACKUP.WC_") Then Kill "BACKUP.WC_"
    MsgBox "恭喜!您的数据已安全备份...", vbInformation + vbOKOnly, "提示信息"
    GoTo LOCALEXIT
    
LOCALERR:
    If Err.Number = 68 Then
       MsgBox "磁盘驱动器设备不能用,请换盘再试", vbCritical, "错误"
       Resume
    End If
    If Err.Number = 70 Then
       MsgBox "驱动器拒绝访问或磁盘被写保防,请换盘再试", vbCritical, "错误"
       Resume
    End If
    
    strmsg = CStr(Err.Number) & "-" & Err.Description
    SFXX = MsgBox(strmsg, vbCritical + vbRetryCancel, "错误")
    If SFXX = vbRetry Then
       Resume
       Else
         Unload BACKUP
    End If

LOCALEXIT:
    Unload BACKUP
End Sub

Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub Drive1_Change()
    On Error GoTo LOCALERR
    Dir1.Path = Drive1.Drive
    GoTo LOCALEXIT
    
LOCALERR:
    If Err.Number = 68 Then
       MsgBox "磁盘驱动器设备不能用,请换盘再试", vbCritical, "错误"
       Resume
    End If
    strmsg = CStr(Err.Number) & "-" & Err.Description
    SFXX = MsgBox(strmsg, vbCritical + vbAbortRetryIgnore, "错误")
    If SFXX = vbRetry Then
       Resume
       Else
         Unload BACKUP
    End If
    

LOCALEXIT:

End Sub

Private Sub Form_Load()
    SFOK = 100
    Set DATBAK = OpenDatabase(App.Path & "\BACKUP.MDB")
    Set RECBACKUP = DATBAK.OpenRecordset("BACKUP", dbOpenDynaset)
'    RECBACKUP.FindFirst ("ID=13")
'    RECBACKUP.Edit
'    RECBACKUP("CS") = App.Path & "\DATA\GRSDS.MDB"
'    RECBACKUP.Update
'    RECBACKUP.MoveFirst
End Sub

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