frmdatabackadd.frm

用vb6.0实现的一个可以通用的企业档案管理系统。

      AutoSize        =   -1  'True
      Caption         =   "文书所属时期                     到"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   180
      Left            =   510
      TabIndex        =   6
      Top             =   540
      Width           =   3150
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "文书导入日期                     到"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   180
      Left            =   510
      TabIndex        =   5
      Top             =   990
      Width           =   3150
   End
End
Attribute VB_Name = "frmDataBackAdd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdBackup_Click()
'*********************************************************
'功能: 备份sys_Image表中的指定时段的的纪录至新数据库文件中
'
'*********************************************************
On Error GoTo ErrorHandler

Dim Msg As String
Dim strTemp As String
Dim rstBackNum As ADODB.Recordset
Dim conNewDatabase As ADODB.Connection

'检查文件名是否合法
If Trim(txtName) = vbNullString Then
    MsgBox "备份文件名称不能为空!", vbInformation
    txtName.SetFocus
    SendKeys "{Home}+{End}"
    Exit Sub
End If

'检查文件路径是否合法
If Trim(txtPath) = vbNullString Then
    MsgBox "备份文件路径不能为空!", vbInformation
    txtPath.SetFocus
    SendKeys "{Home}+{End}"
    Exit Sub
End If
If Dir(txtPath, vbDirectory) = vbNullString Then
    MkDir (txtPath)
End If
If Right(txtPath, 1) <> "\" Then
    txtPath = txtPath & "\"
End If
Screen.MousePointer = vbHourglass

'检查该文件是否已存在
If Dir(txtPath & txtName & ".mdb") <> vbNullString Then
    Msg = MsgBox("该文件名称已经存在,是否覆盖?", vbYesNo + vbInformation)
    Select Case Msg
        Case vbYes
            Kill (txtPath & txtName & ".mdb")
        Case vbNo
            MsgBox "请重新输入文件名称!", vbInformation
            Exit Sub
    End Select
End If

'关闭当前的数据库连接
conCaseMain.Close

'复制数据库文件
FileCopy App.Path & "\CaseMain.mdb", txtPath & txtName & ".mdb"

'打开新数据库文件
Set conNewDatabase = New ADODB.Connection
conNewDatabase.Provider = csProvider
conNewDatabase.CursorLocation = adUseServer
conNewDatabase.ConnectionTimeout = 60
conNewDatabase.Open txtPath & txtName & ".mdb"

'删除新数据库文件中的废纪录
If optSSSQ.Value = True Then
    strTemp = "DELETE FROM sys_Image WHERE Img_SSSQ <'" & txtSSSQ1 & "' AND Img_SSSQ>'" & txtSSSQ2 & "'"
Else
    strTemp = "DELETE FROM sys_Image WHERE Img_Import_Date<#" & DTPDate1.Value & "# AND Img_Import_Date>#" & DTPDate2.Value & "#"
End If
conNewDatabase.Execute strTemp

'取得新数据库中的文件总数和文书总数
Dim FileNum As Long
Set rstBackNum = New ADODB.Recordset
rstBackNum.Open "SELECT COUNT(Img_Case_Code) AS FileNum FROM sys_Image", conNewDatabase, adOpenStatic, adLockOptimistic, adCmdText
FileNum = rstBackNum!FileNum
rstBackNum.Close

'关闭新数据库连接
conNewDatabase.Close

'重新打开当前数据库连接
conCaseMain.Open App.Path & csConCaseMain

'在sys_Backup表中添加一条纪录
Dim rstBack As ADODB.Recordset
Set rstBack = New ADODB.Recordset

If optSSSQ.Value = True Then
    strTemp = "SELECT * FROM sys_Backup WHERE " & _
                        "Back_SSSQ='" & txtSSSQ1 & "_" & txtSSSQ2 & "' AND " & _
                        "Back_SSDate='无'"
Else
    strTemp = "SELECT * FROM sys_Backup WHERE " & _
                        "Back_SSSQ='无' AND " & _
                        "Back_SSDate='" & DTPDate1.Value & "_" & DTPDate2.Value & "'"
End If

rstBack.Open strTemp, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
With rstBack
    If Not .EOF Then .MoveLast
    If Not .BOF Then .MoveFirst
    If .RecordCount > 0 Then
        Msg = MsgBox("该所属时期或时间段的数据已备份,是否重新备份?", vbYesNo + vbInformation)
        Select Case Msg
            Case vbYes
                Do Until .EOF
                    rstBack.Delete
                Loop
            Case vbNo
                MsgBox "请重新选择所属时期或时间段!", vbInformation
                rstBack.Close
                Exit Sub
        End Select
    End If
    .AddNew
        !Back_FileName = txtName & ".mdb"
        !Back_FilePath = txtPath
        !Back_SSSQ = IIf(optSSSQ.Value = True, txtSSSQ1 & "_" & txtSSSQ2, "无")
        !Back_SSDate = IIf(optDate.Value = True, DTPDate1.Value & "_" & DTPDate2.Value, "无")
        !Back_Date = Date
        !Back_Description = "正常"
        !Back_FileNum = FileNum
        '!Back_CaseNUm = rstBackNum!CaseNum
    .Update

End With
rstBack.Close

Screen.MousePointer = vbDefault
MsgBox "备份成功!", vbInformation

Unload Me

Exit Sub
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
        Screen.MousePointer = vbDefault
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdPath_Click()
    Dim fFindPath As frmFindPath
    
    Set fFindPath = New frmFindPath
    fFindPath.Show vbModal
    txtPath.Text = fFindPath.ThisPath
    
End Sub

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

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

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

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

Private Sub Form_Load()

    '初始化备份模式
    optSSSQ.Value = GetSetting(App.Title, "Settings", "DataBackMode", True)
    optSSSQ.Value = Not optSSSQ.Value
    
    '初始化所属时期
    txtSSSQ1 = Year(DateAdd("M", -1, Date)) & Format(Month(DateAdd("M", -1, Date)), "0#")
    txtSSSQ2 = Year(Date) & Format(Month(Date), "0#")
    
    '初始化导入日期
    DTPDate1.Format = dtpLongDate
    DTPDate2.Format = dtpLongDate
    DTPDate1.Value = DateAdd("D", -1, Date)
    DTPDate2.Value = Date

    '初始化文件名称,存放路径
    txtName.Text = vbNullString
    txtPath.Text = vbNullString
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    '保存备份模式
    SaveSetting App.Title, "Settings", "DataBackMOde", optSSSQ.Value
End Sub