frmbackup.frm

用vb编了一个数据库程序

            Call BackupToHD
        Else
            Call BackupToCD
        End If
        lblStep3.Caption = "备份结束!" & vbCrLf & "如果以后要刻入光盘," & vbCrLf & "请保持该文件夹现有名称," & vbCrLf & "并刻在光盘的根目录下!"
        cmdCancel.Caption = "结束(&E)"
    End If


End Sub

Private Function CheckPath() As Boolean

Dim i As Integer

    For i = 65 To 90
        If UCase(Left(txtPath.Text, 3)) = Chr(i) & ":\" Then
            On Error GoTo ErrorHandler
    
            If Dir(txtPath, vbDirectory) = vbNullString Then
                MkDir (txtPath)
                CheckPath = True
                Exit Function
            Else
                CheckPath = True
                Exit Function
            End If
        End If
    Next
    
Exit Function
ErrorHandler:
    If Err Then
        CheckPath = False
        Err.Clear
    End If
End Function

Private Function GetFileInfo() As Boolean
'************************************************************************
'功能: 取得要备份的文件数量和全部文件的大小,对于丢失的文件,则写入日志文件
'调用: cmdNext 的 Step1
'************************************************************************
Dim ErrorFile
Dim FileSize As Long
Dim strSQL As String

Set Fso = CreateObject("Scripting.FileSystemObject")

'这儿打开的纪录集要在全模块内使用
Set rstBackupFile = New ADODB.Recordset

If OptBkToHD.Value = True Then
    strSQL = "SELECT * FROM sys_Image WHERE Img_SSSQ BETWEEN '" & txtSSSQHD1.Text & "' AND '" & txtSSSQHD2.Text & "' ORDER BY QYBM"
Else
    strSQL = "SELECT * FROM sys_Image WHERE Img_SSSQ BETWEEN '" & txtSSSQCD1.Text & "' AND '" & txtSSSQCD2.Text & "' ORDER BY QYBM"
End If

rstBackupFile.Open strSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText

With rstBackupFile
    .MoveLast: .MoveFirst
    If .RecordCount > 0 Then
        Do Until .EOF
            If Dir(!Img_Path & !Img_Name) <> vbNullString Then
                FileSize = FileSize + FileLen(!Img_Path & !Img_Name)
            Else
                Set ErrorFile = Fso.OpenTextFile(App.Path & "\ErrorLog.txt", ForAppending, True)
                ErrorFile.WriteLine (!QYBM & " " & !Nsrmc & " " & !Img_Path & !Img_Name & " " & !Img_Case_Name & " " & !Img_Import_Date)
                ErrorFile.Close
            End If
            .MoveNext
        Loop
    Else
        MsgBox "数据库中没有该时期的文书,无需备份!", vbInformation
        GetFileInfo = False
        Exit Function
    End If
End With

lblFileNum.Caption = rstBackupFile.RecordCount
lblFileSize.Caption = Int(FileSize / (1024 ^ 2))
GetFileInfo = True

End Function

Private Function GetDiskInfo() As Boolean
    On Error Resume Next
    
    Dim Fso As FileSystemObject
    Dim ThisDisk As Drive
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set ThisDisk = Fso.GetDrive(Fso.GetDriveName(Left(txtPath.Text, 3)))
    With ThisDisk
        If .DriveType <> 2 Then
            MsgBox "请选择磁盘！", vbInformation
            GetDiskInfo = False
            Exit Function
        End If
        frmStep22.Caption = "备份磁盘信息"
        lblHDInfoL.Caption = "备份磁盘盘符:"
        lblHDFreeSizeL.Caption = "备份磁盘剩余空间:"
        lblDiskInfo.Caption = .DriveLetter
        lblFreeSpace.Caption = vbNullString
        lblFreeSpace.Caption = Int(.AvailableSpace / (1024 ^ 2))
    End With
    GetDiskInfo = True
    
End Function

Private Function GetCD_RomInfo() As Boolean
    On Error Resume Next
    
    Dim Msg As String
    Dim Fso As FileSystemObject
    Dim ThisDisk As Drive
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set ThisDisk = Fso.GetDrive(Fso.GetDriveName(Drive.Drive))
    With ThisDisk
        If .DriveType <> 4 Then
            MsgBox "请选择可擦写光驱！", vbInformation
            GetCD_RomInfo = False
            Exit Function
        End If
        If .IsReady = False Then
1:          Msg = MsgBox("请插入光盘,按[确定]继续!", vbYesNo + vbInformation)
            Select Case Msg
            Case vbYes
                If .IsReady = False Then
                    GoTo 1
                End If
            Case vbNo
                GetCD_RomInfo = False
                Exit Sub
            End Select
        End If
        frmStep22.Caption = "备份光盘信息"
        lblHDInfoL.Caption = "备份光盘盘符:"
        lblHDFreeSizeL.Caption = "备份光盘剩余空间:"
        lblDiskInfo.Caption = .DriveLetter
        lblFreeSpace.Caption = vbNullString
        lblFreeSpace.Caption = Int(.AvailableSpace / (1024 ^ 2))
    End With
    GetCD_RomInfo = True
    
End Function

Private Sub CmdPrevious_Click()

    '根据不同的步骤,显示不同的控件
    If Step2 Then
        cmdPrevious.Visible = False
        frmStep1.Visible = True
        frmStep21.Visible = False
        frmStep22.Visible = False
        frmStep3.Visible = False
        Step1 = True
        Step2 = False
        Step3 = False
        Exit Sub
    End If
    If Step3 Then
        cmdPrevious.Visible = True
        frmStep1.Visible = False
        frmStep21.Visible = True
        frmStep22.Visible = True
        frmStep3.Visible = False
        Step1 = False
        Step2 = True
        Step3 = False
    End If

End Sub

Private Function CheckSize() As Boolean
    If Val(lblFileNum.Caption) + csDiskRemain >= Val(lblFreeSpace.Caption) Then
        CheckSize = False
    Else
        CheckSize = True
    End If
End Function

Private Sub CmdSelePath_Click()
    frmFindPath.Show vbModal
    txtPath.Text = frmFindPath.ThisPath
    
End Sub

Private Sub Form_Load()

    '初始化所属时期
    txtSSSQHD1.Text = Year(DateAdd("M", -1, Date)) & Format(Month(DateAdd("M", -1, Date)), "0#")
    txtSSSQHD2.Text = Year(Date) & Format(Month(Date), "0#")
    txtSSSQCD1.Text = txtSSSQHD1.Text
    txtSSSQCD2.Text = txtSSSQHD2.Text
    
    '取得上一次备份时的选择(备份至其他路径或光盘)
    Dim LastChoice As String
    LastChoice = GetSetting(App.Title, "Settings", "LastChoice", "CD")
    If LastChoice = "CD" Then
        OptBkToCD.Value = True
        OptBkToHD.Value = False
    Else
        OptBkToHD.Value = True
        OptBkToCD.Value = False
    End If
    
    '现在是第一步
    Step1 = True
    cmdPrevious.Visible = False
    frmStep1.Visible = True
    frmStep21.Visible = False
    frmStep22.Visible = False
    frmStep3.Visible = False
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    '保存本次备份的选择
    If OptBkToHD.Value = True Then
        SaveSetting App.Title, "Settings", "LastChoice", "HD"
    Else
        SaveSetting App.Title, "Settings", "LastChoice", "CD"
    End If
    Unload Me
End Sub

Private Sub OptBkToCD_Click()
    
    '初始化界面
    txtSSSQCD1.Enabled = True
    txtSSSQCD2.Enabled = True
    txtSSSQCD1.BackColor = &H80000005
    txtSSSQCD2.BackColor = &H80000005
    UpDCD1.Enabled = True
    UpDCD2.Enabled = True
    chkRegToCD.Enabled = True
    Drive.Enabled = True
    Drive.BackColor = &H80000005
    
    txtPath.Enabled = False
    CmdSelePath.Enabled = False
    txtSSSQHD1.Enabled = False
    txtSSSQHD2.Enabled = False
    txtPath.BackColor = &H8000000F
    txtSSSQHD1.BackColor = &H8000000F
    txtSSSQHD2.BackColor = &H8000000F
    UpDHD1.Enabled = False
    UpDHD2.Enabled = False
    chkRegToHD.Enabled = False
    
End Sub

Private Sub OptBkToHD_Click()

    '初始化界面
    txtPath.Enabled = True
    CmdSelePath.Enabled = True
    txtSSSQHD1.Enabled = True
    txtSSSQHD2.Enabled = True
    txtPath.BackColor = &H80000005
    txtSSSQHD1.BackColor = &H80000005
    txtSSSQHD2.BackColor = &H80000005
    UpDHD1.Enabled = True
    UpDHD2.Enabled = True
    chkRegToHD.Enabled = True
    
    txtSSSQCD1.Enabled = False
    txtSSSQCD2.Enabled = False
    txtSSSQCD1.BackColor = &H8000000F
    txtSSSQCD2.BackColor = &H8000000F
    UpDCD1.Enabled = False
    UpDCD2.Enabled = False
    chkRegToCD.Enabled = False
    Drive.Enabled = False
    Drive.BackColor = &H8000000F
    
End Sub

Private Sub UpDHD1_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQHD1, 4) & "/" & Right(txtSSSQHD1, 2) & "/01")
    txtSSSQHD1.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDHD1_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQHD1, 4) & "/" & Right(txtSSSQHD1, 2) & "/01")
    txtSSSQHD1.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Sub UpDHD2_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQHD2, 4) & "/" & Right(txtSSSQHD2, 2) & "/01")
    txtSSSQHD2.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDHD2_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQHD2, 4) & "/" & Right(txtSSSQHD2, 2) & "/01")
    txtSSSQHD2.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Sub UpDCD1_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQCD1, 4) & "/" & Right(txtSSSQCD1, 2) & "/01")
    txtSSSQCD1.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDCD1_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQCD1, 4) & "/" & Right(txtSSSQCD1, 2) & "/01")
    txtSSSQCD1.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Sub UpDCD2_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQCD2, 4) & "/" & Right(txtSSSQCD2, 2) & "/01")
    txtSSSQCD2.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDCD2_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQCD2, 4) & "/" & Right(txtSSSQCD2, 2) & "/01")
    txtSSSQCD2.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Function BackupToHD() As Boolean
'************************************************************************
'功能: 备份文书,包括复制文件到磁盘的指定目录下,修改数据库中的相应字段信息
'调用: cmdNext 的 Step3
'************************************************************************
On Error GoTo ErrorHandler
Dim ThisDisk As Drive

Me.MousePointer = vbHourglass
Set ThisDisk = Fso.GetDrive(Fso.GetDriveName(Left(txtPath.Text, 3)))

'在选定的目录下建立备份目录
If Right(txtPath, 1) <> "\" Then
    txtPath = txtPath & "\"
End If
If Dir(txtPath & txtSSSQCD1 & "_" & txtSSSQCD2, vbDirectory) = vbNullString Then
    MkDir (txtPath & txtSSSQCD1 & "_" & txtSSSQCD2)
Else
    Fso.DeleteFolder (txtPath & txtSSSQCD1 & "_" & txtSSSQCD2)
    MkDir (txtPath & txtSSSQCD1 & "_" & txtSSSQCD2)
End If

With rstBackupFile
    .MoveLast: .MoveFirst
    Do Until .EOF
        
        '复制文件
        If Dir(!Img_Path & !Img_Name) <> vbNullString Then
            FileCopy !Img_Path & !Img_Name, txtPath & txtSSSQCD1 & "_" & txtSSSQCD2 & "\" & !Img_Name
                
            '修改数据库中相应字段信息
            !Img_BackupPath = txtPath & txtSSSQCD1 & "_" & txtSSSQCD2
            !Img_BackupMode = True
            !Img_BackupDate = Date
            .Update
        End If
        
        '移到下一条记录
        .MoveNext
    Loop
    
End With

BackupToHD = True
Me.MousePointer = vbDefault

Exit Function
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbInformation
        Err.Clear
        BackupToHD = False
    End If
End Function

Private Function BackupToCD() As Boolean
'************************************************************************
'功能: 备份文书,包括复制文件到光盘的指定目录下,修改数据库中的相应字段信息
'调用: cmdNext 的 Step3
'************************************************************************
On Error GoTo ErrorHandler

Dim ThisDisk As Drive
Dim Msg As String

Me.MousePointer = vbHourglass
Set ThisDisk = Fso.GetDrive(Fso.GetDriveName(Drive.Drive))

'在光盘根目录下建立备份目录
If Dir(ThisDisk.DriveLetter & ":\" & txtSSSQCD1 & "_" & txtSSSQCD2, vbDirectory) <> vbNullString Then
    MkDir (ThisDisk.DriveLetter & ":\" & txtSSSQCD1 & "_" & txtSSSQCD2)
End If

With rstBackupFile
    .MoveLast: .MoveFirst
    Do Until .EOF
    
        '复制文件
        If Dir(!Img_Path & !Img_Name) <> vbNullString Then
            FileCopy !Img_Path & !Img_Name, ThisDisk.DriveLetter & ":\" & txtSSSQCD1 & "_" & txtSSSQCD2 & "\" & !Img_Name
        
            '检查光盘剩余空间
            If ThisDisk.AvailableSpace < 10000000 Then
1:          Msg = MsgBox("光盘已满，请插入新的光盘，按[确定]继续", vbYesNo + vbExclamation)
                Select Case Msg
                Case vbYes
                    If ThisDisk.IsReady = True Then
                        
                    Else
                        GoTo 1
                    End If
                Case vbNo
                    MsgBox "本次备份未完成!", vbInformation
                    BackupToCD = False
                    Exit Function
                End Select
            End If
            
            '修改数据库中相应字段信息
            !Img_BackupPath = ThisDisk.DriveLetter & ":\" & txtSSSQCD1 & "_" & txtSSSQCD2
            !Img_BackupMode = True
            !Img_BackupDate = Date
            .Update
        End If
        
        '移到下一条记录
        .MoveNext
    Loop
    
End With

BackupToCD = True
Me.MousePointer = vbDefault

Exit Function
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbInformation
        Err.Clear
        BackupToCD = False
    End If
End Function