frmmain.frm

定时备份Oracle数据库和文件的程序 支持RAR压缩功能

      intFlag = HTTOPLEFT
     Case 1
      intFlag = HTTOPRIGHT
     Case 2
      intFlag = HTBOTTOMLEFT
     Case 3
      intFlag = HTBOTTOMRIGHT
     Case 10
      intFlag = HTLEFT
     Case 11
      intFlag = HTRIGHT
     Case 12
      intFlag = HTBOTTOM
     Case 13
      intFlag = HTTOP
    End Select

    ReturnVal = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, intFlag, 0)

  End If
End Sub

'*************************************************************************
'**函 数 名：imgCorner_MouseMove
'**输    入：Index(Integer)  -
'**        ：Button(Integer) -
'**        ：Shift(Integer)  -
'**        ：X(Single)       -
'**        ：Y(Single)       -
'**输    出：无
'**功能描述：
'**全局变量：
'**调用模块：
'**作    者：叶帆
'**日    期：2003年04月29日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Private Sub imgCorner_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Me.WindowState <> 0 Then Exit Sub
  Dim intFlag As Long, mIndex As Integer
  If Me.WindowState = 0 Then
    Dim ReturnVal As Long
    Select Case Index
     Case 0
      mIndex = 8
     Case 1
      mIndex = 6
     Case 2
      mIndex = 6
     Case 3
      mIndex = 8
     Case 10
      mIndex = 9
     Case 11
      mIndex = 9
     Case 12
      mIndex = 7
     Case 13
      mIndex = 7
    End Select

    If Index < 10 Then imgCorner(Index).MousePointer = mIndex
    If Index > 10 And Index < 13 Then imgBorder(Index - 10).MousePointer = mIndex
    If Index > 12 Then imgTitle.MousePointer = mIndex
  End If
End Sub

'*************************************************************************
'**函 数 名：imgTitle_MouseDown
'**输    入：Button(Integer) -
'**        ：Shift(Integer)  -
'**        ：X(Single)       -
'**        ：Y(Single)       -
'**输    出：无
'**功能描述：
'**全局变量：
'**调用模块：
'**作    者：叶帆
'**日    期：2003年04月29日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Private Sub imgTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call imgCorner_MouseDown(13, Button, Shift, X, Y)
End Sub

Private Sub imgTitle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call imgCorner_MouseMove(13, Button, Shift, X, Y)
End Sub


'*************************************************************************
'**函 数 名：DeloldFile
'**输    入：
'**输    出：无
'**功能描述：
'**全局变量：
'**调用模块：
'**作    者：
'**日    期：
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
'删除10天以前的备份日志和文件

Private Sub DelOldFile()
  Dim OldLogFile As String
  Dim OldDmpFile As String
  
  If Right(App.Path, 1) = "\" Then
    If Dir(App.Path & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "log.log") <> "" Then
      Kill App.Path & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "log.log"
    End If
    
    If Dir(App.Path & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "dmp.dmp") <> "" Then
      Kill App.Path & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "dmp.dmp"
    End If
  Else
   
    If Dir(App.Path & "\" & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "log.log") <> "" Then
      Kill App.Path & "\" & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "log.log"
    End If
     
    If Dir(App.Path & "\" & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "dmp.dmp") <> "" Then
      Kill App.Path & "\" & Trim(TxtUser.Text) & Format(DateAdd("d", -10, Now), "yyyymmdd") & "dmp.dmp"
    End If
   'OldLogFile = App.Path & "\" & Format(DateAdd(d, 4, Now), "yyyymmdd") & "log.log "
   'OldDmpFile = App.Path & "\" & Format(DateAdd(d, 4, Now), "yyyymmdd") & "dmp.dmp"
 End If

End Sub


'由注册表中得到保存的信息
Private Sub GetReg()
 
On Error Resume Next
  
    '启动备份时间
    DtStart.Value = Format(GetSetting(App.Title, "数据备份", "启动备份时间", "0:00:00"), "HH:MM:SS")
   ' txttabsps.Text = GetSetting(App.Title, "数据备份", "备份表空间", "ylbxzjj,yy1,yy2")
  If GetValue(HKEY_LOCAL_MACHINE, "SOFTWARE\ORACLE\HOME0", "ORACLE_HOME", "") = 0 Then
    Exppath = Regvalue & "\bin"
   End If
    CboDay.Text = GetSetting(App.Title, "数据备份", "备份日期", "")
    txtexp.Text = GetSetting(App.Title, "数据备份", "备份程序", "")
    TxtConn.Text = GetSetting(App.Title, "数据备份", "连接串", "")
    TxtUser.Text = GetSetting(App.Title, "数据备份", "用户", "system")
    TxtPwd.Text = GetSetting(App.Title, "数据备份", "密码", "manager")
    Opt(0).Value = GetSetting(App.Title, "数据备份", "每月", "")
    Opt(2).Value = GetSetting(App.Title, "数据备份", "每周", "")
    Opt(1).Value = GetSetting(App.Title, "数据备份", "每日", "")
    TxtSoure.Text = GetSetting(App.Title, "数据备份", "来源目录", "")
    TxtTag.Text = GetSetting(App.Title, "数据备份", "目标目录", "")
    OptYes.Value = GetSetting(App.Title, "数据备份", "是", "")
    OptNo.Value = GetSetting(App.Title, "数据备份", "否", "")
    TxtDmpPath.Text = GetSetting(App.Title, "数据备份", "Dmp目录", "")
    
End Sub
'保存信息到注册表中
Private Sub SaveReg()

On Error Resume Next
   
    '启动备份时间
    SaveSetting App.Title, "数据备份", "启动备份时间", Format(DtStart.Value, "hh:mm:ss")
    SaveSetting App.Title, "数据备份", "备份日期", CboDay.Text
    SaveSetting App.Title, "数据备份", "备份程序", txtexp.Text
    SaveSetting App.Title, "数据备份", "连接串", TxtConn.Text
    SaveSetting App.Title, "数据备份", "用户", Trim(TxtUser.Text)
    SaveSetting App.Title, "数据备份", "密码", Trim(TxtPwd.Text)
    SaveSetting App.Title, "数据备份", "每月", Opt(0).Value
    SaveSetting App.Title, "数据备份", "每周", Opt(2).Value
    SaveSetting App.Title, "数据备份", "每日", Opt(1).Value
    SaveSetting App.Title, "数据备份", "来源目录", Trim(TxtSoure.Text)
    SaveSetting App.Title, "数据备份", "目标目录", Trim(TxtTag.Text)
    SaveSetting App.Title, "数据备份", "是", OptYes.Value
    SaveSetting App.Title, "数据备份", "否", OptNo.Value
    SaveSetting App.Title, "数据备份", "Dmp目录", Trim(TxtDmpPath.Text)
End Sub
Private Sub ItemUnEanble()
    Opt(0).Enabled = False
    Opt(1).Enabled = False
    Opt(2).Enabled = False
    CboDay.Enabled = False
    txtexp.Enabled = False
    TxtConn.Enabled = False
    TxtUser.Enabled = False
    TxtPwd.Enabled = False
    DtStart.Enabled = False
    CmdOpen.Enabled = False
    CmdSave.Enabled = False
    TxtSoure.Enabled = False
    TxtTag.Enabled = False
    TxtDmpPath.Enabled = False
    CmdOraFl.Enabled = False
    CmdFileS.Enabled = False
    CmdFileD.Enabled = False
    
    
    
End Sub

Private Sub ItemEanble()
    Opt(0).Enabled = True
    Opt(1).Enabled = True
    Opt(2).Enabled = True
    CboDay.Enabled = True
    txtexp.Enabled = True
    TxtConn.Enabled = True
    TxtUser.Enabled = True
    TxtPwd.Enabled = True
    DtStart.Enabled = True
    CmdOpen.Enabled = True
    TxtSoure.Enabled = True
    TxtTag.Enabled = True
    TxtDmpPath.Enabled = True
    CmdOraFl.Enabled = True
    CmdFileS.Enabled = True
    CmdFileD.Enabled = True
End Sub


Private Sub BackData()
 If Right(App.Path, 1) = "\" Then
    LogFile = TxtDmpPath & Trim(TxtUser.Text) & Format(Now, "yyyymmdd") & "log.log"
    DmpFile = TxtDmpPath & Trim(TxtUser.Text) & Format(Now, "yyyymmdd") & "dmp.dmp"
  Else
   LogFile = TxtDmpPath & "\" & Trim(TxtUser.Text) & Format(Now, "yyyymmdd") & "log.log"
   DmpFile = TxtDmpPath & "\" & Trim(TxtUser.Text) & Format(Now, "yyyymmdd") & "dmp.dmp"
 End If
 
If Len(txtexp.Text) = 0 Then
  MsgBox "请设置导出程序！一般为exp.exe或exp*.exe"
 Else
       
       CmdLine = Trim(txtexp.Text) & Space(2) & TxtUser.Text & "/" & TxtPwd.Text & "@" & TxtConn.Text & " file=" & DmpFile & " log=" & LogFile   '& "  OWNER=" & txttabsps.Text
End If
Dim L As Long
L = WinExec(CmdLine, 0)
'判断是否完成
DoEvents
If L > 32 Then
'If CLng(WinExec()) > 32 Then
  FinishBack = True
End If
End Sub

Private Sub Opt_Click(Index As Integer)
 
Select Case Index
 Case 0

   CboDay.Clear
   For iNum = 1 To 31
    CboDay.AddItem iNum
   Next
   CboDay.ListIndex = 0
   
    For iLIst = 0 To CboDay.ListCount - 1
         If CboDay.List(iLIst) = GetSetting(App.Title, "数据备份", "备份日期", "") Then
            CboDay.ListIndex = iLIst
            Exit For
         
         End If
     
     Next
 
Case 2
   CboDay.Clear
   CboDay.AddItem "星期一"
   CboDay.AddItem "星期二"
   CboDay.AddItem "星期三"
   CboDay.AddItem "星期四"
   CboDay.AddItem "星期五"
   CboDay.AddItem "星期六"
   CboDay.AddItem "星期日"
   
   CboDay.ListIndex = 0
    For iLIst = 0 To CboDay.ListCount - 1
         If CboDay.List(iLIst) = GetSetting(App.Title, "数据备份", "备份日期", "") Then
            CboDay.ListIndex = iLIst
            Exit For
         
         End If
     
     Next
 Case 1
   CboDay.Clear
   CboDay = ""
  
 End Select
 
End Sub

Private Sub Timer1_Timer()
   Dim intDay As Integer
   
   intDay = Day(DateAdd("D", -1, Year(Now) & "-" & Month(Now) + 1 & "-1"))
  ' Debug.Print IIf(intDay < Trim(CboDay.Text), intDay, Trim(CboDay.Text))

On Error Resume Next
 If Opt(0).Value Then
'    Debug.Print Day(Now)
'    Debug.Print CboDay.Text
   If Trim(Str(Day(Now))) = IIf(intDay < Trim(CboDay.Text), intDay, Trim(CboDay.Text)) And Format(Now, "hh:mm:ss") = Format(DtStart.Value, "hh:mm:ss") Then
     If Len(TxtDmpPath) > 0 Then BackData
        'DelOldFile
     If Len(TxtTag) > 0 Then BackFile
    End If
 
 ElseIf Opt(2).Value Then
   ' Debug.Print WeekdayName(Weekday(Now))
    If WeekdayName(Weekday(Now)) = Trim(CboDay.Text) And Format(Now, "hh:mm:ss") = Format(DtStart.Value, "hh:mm:ss") Then
     If Len(TxtDmpPath) > 0 Then BackData
        'DelOldFile
     If Len(TxtTag) > 0 Then BackFile
    End If
 
 
 Else

    If Format(Now, "hh:mm:ss") = Format(DtStart.Value, "hh:mm:ss") Then
     If Len(TxtDmpPath) > 0 Then BackData
       ' DelOldFile
     If Len(TxtTag) > 0 Then BackFile
    End If
 End If
    
End Sub

Private Sub BackFile()
  Dim StrS As String
  Dim StrD As String
  Dim StrCmd As String
  Dim L As Long
  
  StrS = Trim(TxtSoure.Text)
  StrD = Trim(TxtTag.Text)
  
  If Len(StrS) = 0 Or Len(StrD) = 0 Then
     MsgBox "来源文件夹或者目标文件夹不能力空，请检查！", vbInformation + vbOKOnly
     Exit Sub
  Else
    If OptYes Then
       StrCmd = """" & App.Path & "\rar.exe" & """" & " A " & """" & StrD & "\" & Format(Now, "yyyymmdd") & "bak.rar" & """" & " -AD " & """" & StrS & """"
         
       'StrCmd = App.Path & "\rar.exe a " & StrD & "\" & Format(Now, "yyyymmdd") & "bak.rar" & """" & " -AD " & """" & StrS & """"
       Debug.Print StrCmd
      ' WinExec StrCmd, 4
       RarExect StrCmd
    Else
    
     ' StrCmd = "xCopy " & """" & StrS & """" & " " & """" & StrD & """" & " /s/y"
       StrCmd = """" & StrS & """" & " " & """" & StrD & """" & " /s/y"
     ' StrCmd = "XCopy " & ShortName(StrS) & ShortName(StrD) & " /s/y"
      
       Debug.Print StrCmd
'
'       Open App.Path & "\Temp_filecopy.bat" For Output As #1
'       Print #1, StrCmd
'       Print #1, "exit"
'       Close #1
     ' L = WinExec(StrCmd, 4)
      Shell "xcopy " & StrCmd
     ' Shell "cmd.exe " & App.Path & "\Temp_filecopy.bat"
     '  Kill App.Path & "\Temp_filecopy.bat"
    End If

  End If

End Sub


Public Function IsDirName(strPath As String) As Boolean
  'Purpose   :   判断指定的路径是不是一个一个存在的目录
  On Error GoTo PROC_ERR
                Dim blnCheck     As Boolean
                blnCheck = GetAttr(strPath) And vbDirectory
                IsDirName = blnCheck
PROC_EXIT:
  Exit Function
PROC_ERR:
    IsDirName = False
  End Function