frmbackup.frm

此为水费收费管理系统

         Height          =   180
         Index           =   0
         Left            =   252
         TabIndex        =   13
         Top             =   312
         Width           =   1800
      End
   End
   Begin SmartXPButton.XpButton Command1 
      Default         =   -1  'True
      Height          =   435
      Index           =   0
      Left            =   4740
      TabIndex        =   5
      Top             =   2940
      Width           =   1515
      _ExtentX        =   2672
      _ExtentY        =   767
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Caption         =   "备 份(&O)"
      PictureSmoothBackColor=   13882323
      ButtonPicture   =   "FrmBackUp.frx":0B3E
   End
   Begin SmartXPButton.XpButton Command1 
      Height          =   435
      Index           =   1
      Left            =   4740
      TabIndex        =   6
      Top             =   3660
      Width           =   1515
      _ExtentX        =   2672
      _ExtentY        =   767
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Caption         =   "取 消(&C)"
      PictureSmoothBackColor=   13882323
      ButtonPicture   =   "FrmBackUp.frx":0C98
   End
   Begin SmartXPButton.XpButton Command1 
      Height          =   435
      Index           =   2
      Left            =   4740
      TabIndex        =   7
      Top             =   4380
      Width           =   1515
      _ExtentX        =   2672
      _ExtentY        =   767
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Caption         =   "帮 助(&H)"
      PictureSmoothBackColor=   13882323
      ButtonPicture   =   "FrmBackUp.frx":0DF2
   End
End
Attribute VB_Name = "FrmBackUp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public MdbFileName As String        '数据备份使用的 数据库文件：MDB(扩展名)
Dim NamFileName As String
Public NamPathName As String        '数据备份后的压缩文件：NAM(扩展名)
Dim Fs As New Scripting.FileSystemObject

Private Sub Command1_Click(Index As Integer)
    Select Case Index
        Case 0
            On Error GoTo NumErr
            MdbFileName = Trim(Text1(0).Text)
            NamPathName = Trim(Text1(1).Text)
            If Len(MdbFileName) = 0 Then
                MsgBox "没有选择要备份的数据库文件！", vbOKOnly + vbInformation, "文件出错..."
                Exit Sub
            End If
            If Len(NamPathName) = 0 Then
                MsgBox "没有设定备份文件路径和文件名！", vbOKOnly + vbInformation, "文件出错..."
                Exit Sub
            End If
            If Fs.FileExists(MdbFileName) = False Then
                MsgBox "找不到数据库文件：" & MdbFileName, vbCritical + vbOKOnly, "文件出错..."
                Exit Sub
            End If
            If Fs.FileExists(NamPathName) = True Then
                If MsgBox("备份文件：" & NamPathName & " 已存在！" & vbCrLf & vbCrLf & _
                    "你真的要覆盖此文件吗？", vbCritical + vbOKCancel, "文件存在...") = vbOK Then
                    Fs.DeleteFile NamPathName, True
                Else
                    Exit Sub
                End If
            End If
            MdlMain.FrmStatusType = "数据备份"
            FrmStatus.Label1.Caption = "正在备份数据..."
            FrmStatus.Show vbModal
            If MdlMain.FrmStatusType = "备份成功" Then
                Dim cn As New ADODB.Connection
                Dim Rec As New ADODB.Recordset
                cn.Open DbLoginSql
                cn.Execute "delete from lqbackup where backupfile='" & NamPathName & "'"
                Rec.CursorLocation = adUseClient
                Rec.Open "select * from lqbackup", cn, adOpenDynamic, adLockOptimistic
                With Rec
                    .AddNew
                    .Fields("usedate").Value = Label1(0).Caption
                    .Fields("backupdate").Value = Label1(1).Caption
                    .Fields("backupuser").Value = Label1(2).Caption
                    .Fields("demo").Value = IIf(Text1(2).Text = "", " ", Text1(2).Text)
                    .Fields("backupfile").Value = NamPathName
                    .Update
                End With
                Rec.Close: Set Rec = Nothing
                cn.Close: Set cn = Nothing
                MsgBox "系统数据备份成功！", vbOKOnly + vbInformation, "恭喜恭喜..."
                MdlMain.FrmStatusType = ""
                Unload Me
            ElseIf MdlMain.FrmStatusType = "路径出错" Then
                MdlMain.FrmStatusType = ""
                MsgBox "路径/文件访问出错！", vbOKOnly + vbQuestion, "备份数据"
            ElseIf MdlMain.FrmStatusType = "未知错误" Then
                MdlMain.FrmStatusType = ""
                MsgBox "数据备份过程中出现未知错误，请关闭窗口后重试一次。" & vbCrLf & vbCrLf & _
                    "如果继续出现错误，请与本系统开发人员联系...", vbOKOnly + vbCritical, "备份数据"
            End If
            Exit Sub
NumErr:
            If Err.Number = 70 Then
                MsgBox "系统数据库访问出错，请确认是否正在使用数据库！！" & vbCrLf & vbCrLf & _
                    "如果正在使用数据库请关闭后再试一次。" & vbCrLf & vbCrLf & _
                    "如果还是不行请联系系统开发人员。", vbOKOnly + _
                    vbExclamation, "数据库正在使用？？"
            Else
                MsgBox Err.Number & "：" & Err.Description, vbOKOnly + vbQuestion, "系统出错！"
            End If
        Case 1
            Unload Me
        Case 2
            MsgBox "不好意思哦！本窗口暂未提供帮助！！", vbOKOnly + vbInformation, "很抱歉..."
    End Select
End Sub

Private Sub Command2_Click(Index As Integer)
    Select Case Index
        Case 0
            On Error GoTo Er_Cancel
            With CommonDialog1
                .DialogTitle = "请选择要备份的数据库文件..."
                .CancelError = True
                .FileName = App.Path & "\chxn\maindb.mdb"
                .Filter = "*.mdb|*.mdb"
                .ShowOpen
                MdbFileName = Trim(.FileName)
            End With
            If Len(MdbFileName) = 0 Then Exit Sub
            If Fs.FileExists(MdbFileName) = False Then
                MsgBox "找不到你选定的文件：" & MdbFileName, vbCritical + vbOKOnly, "文件出错..."
            Else
                Text1(0).Text = MdbFileName
            End If
Er_Cancel:
        Case 1
            Dim iNull As Integer, lpIDList As Long, lResult As Long
            Dim sPath As String, udtBI As BrowseInfo
            With udtBI
                .hWndOwner = Me.hWnd
                .lpszTitle = lstrcat("C:\", "")
                .ulFlags = BIF_RETURNONLYFSDIRS
            End With
            lpIDList = SHBrowseForFolder(udtBI)
            If lpIDList Then
                sPath = String$(MAX_PATH, 0)
                SHGetPathFromIDList lpIDList, sPath
                CoTaskMemFree lpIDList
                iNull = InStr(sPath, vbNullChar)
                If iNull Then
                    sPath = Left$(sPath, iNull - 1)
                End If
                NamPathName = IIf(Right(sPath, 1) = "\", Left(sPath, Len(sPath) - 1), sPath)
                Text1(1).Text = NamPathName & NamFileName
            End If
    End Select
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
    Me.KeyPreview = True
    Label1(0).Caption = MdlMain.LoginTime.LgTime
    Label1(1).Caption = Format(Date, "yyyy-mm-dd")
    Label1(2).Caption = MdlMain.LoginUser
    MdbFileName = SysDbPath & "\maindb.mdb"
    NamPathName = App.Path & "\backup"
    If Fs.FolderExists(NamPathName) = False Then Fs.CreateFolder NamPathName
    NamFileName = "\" & Year(Format(Date, "yyyy-mm-dd")) & _
        IIf(Len(Month(Format(Date, "yyyy-mm-dd"))) = 1, "0" & Month(Format(Date, "yyyy-mm-dd")), _
        Month(Format(Date, "yyyy-mm-dd"))) & _
        IIf(Len(Day(Format(Date, "yyyy-mm-dd"))) = 1, "0" & Day(Format(Date, "yyyy-mm-dd")), _
        Day(Format(Date, "yyyy-mm-dd"))) & ".nam"
    Text1(0).Text = MdbFileName
    Text1(1).Text = NamPathName & NamFileName
    Text1(2).Text = ""
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Set Fs = Nothing
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).SelStart = 0
    Text1(Index).SelLength = Len(Text1(Index).Text)
End Sub