funcdefine.bas

oracle和sql自动备份系统

Attribute VB_Name = "FuncDefine"
Public Sub savekey(Hkey As Long, strPath As String)

Dim keyhand&

r = RegCreateKey(Hkey, strPath, keyhand&)

r = RegCloseKey(keyhand&)

End Sub

Public Function getstring(Hkey As Long, strPath As String, strValue As String)

Dim keyhand As Long

Dim datatype As Long

Dim lResult As Long

Dim strBuf As String

Dim lDataBufSize As Long

Dim intZeroPos As Integer

r = RegOpenKey(Hkey, strPath, keyhand)

lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)

If lValueType = REG_SZ Then
    
    strBuf = String(lDataBufSize, " ")
    
    lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
    
    If lResult = ERROR_SUCCESS Then
        
        intZeroPos = InStr(strBuf, Chr$(0))
        
        If intZeroPos > 0 Then
            getstring = Left$(strBuf, intZeroPos - 1)
        Else
            getstring = strBuf
        
        End If
    
    End If
End If
End Function


Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)

Dim keyhand As Long

Dim r As Long

r = RegCreateKey(Hkey, strPath, keyhand)

r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata) * 2)

r = RegCloseKey(keyhand)
End Sub


Function getdword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String) As Long

Dim lResult As Long

Dim lValueType As Long

Dim lBuf As Long

Dim lDataBufSize As Long

Dim r As Long

Dim keyhand As Long

r = RegOpenKey(Hkey, strPath, keyhand)

 ' Get length/data type
lDataBufSize = 4
    
lResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)

If lResult = ERROR_SUCCESS Then
    
    If lValueType = REG_DWORD Then
        
        getdword = lBuf
    
    End If
'Else
'    Call errlog("GetDWORD-" & strPath, False)
End If

r = RegCloseKey(keyhand)
    
End Function

Function SaveDword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
    
    Dim lResult As Long
    
    Dim keyhand As Long
    
    Dim r As Long
    
    r = RegCreateKey(Hkey, strPath, keyhand)
    
    lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)
    'If lResult <> error_success Then Call errlog("SetDWORD", False)
    
    r = RegCloseKey(keyhand)
End Function

Public Function DeleteKey(ByVal Hkey As Long, ByVal strKey As String)

Dim r As Long

r = RegDeleteKey(Hkey, strKey)

End Function

Public Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)

Dim keyhand As Long

r = RegOpenKey(Hkey, strPath, keyhand)

r = RegDeleteValue(keyhand, strValue)

r = RegCloseKey(keyhand)

End Function



Sub MyProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long)

'根据Msg判断，消息是否是图标发出的，如果是，再进行处理

    If Msg = IconMsg Then
    
        If lParam = WM_LBUTTONDOWN Then
        
            frmIconTest.Show  '如果在图标上按下了左键则显示窗体

        End If
        
    End If
    
'执行全程变量OldWinProc记录的原消息处理程序的地址中的消息处理程序

    CallWindowProc OldWinProc, hWnd, Msg, wParam, lParam
    
End Sub

Public Function EncryptText(mvarText, mvarKey) As String  '口令加密
Dim textChar As String * 1
Dim keyChar As String * 1
Dim encryptedChar As Integer
Dim i As Integer

If mvarText = "" Then '输入口令为空
    EncryptText = mvarKey
Else
    EncryptText = ""
    For i = 1 To Len(mvarText)
        textChar = Mid(mvarText, i, 1)
        keyChar = Mid(mvarKey, (i Mod Len(mvarKey)) + 1)
        encryptedChar = Asc(textChar) Xor Asc(keyChar)
        EncryptText = EncryptText + Chr(encryptedChar)
    Next
End If
End Function


Public Sub CenterForm(frm As Form)   '窗体居中
    frm.Top = (Screen.Height \ 2 - frm.Height \ 2) * 0.75
    frm.Left = Screen.Width \ 2 - frm.Width \ 2
End Sub

Public Function Sqlbackup()
   
    Dim Temppasswod As String
    
    Dim Tempuserid As String
    
    Dim Tempservername As String
    
    Dim Tempdbname As String
    
    Dim Temppath As String
    
    Dim Sqlstr As String
    
    
     Backflag = True
      
     Frmmassage.Show
      '备份开始
    
     Tempuserid = GetSetting("databackup", "sysinformation", "Txt_Sql_userid")
     
     If Trim(GetSetting("databackup", "sysinformation", "Txt_Sql_password")) = "" Then
     
     Temppasswod = ""
     
     Else
     
     Temppasswod = EncryptText(GetSetting("databackup", "sysinformation", "Txt_Sql_password"), "ljp")
     
     End If
     
     Tempservername = GetSetting("databackup", "sysinformation", "Txt_Sql_servername")
     
     Tempdbname = GetSetting("databackup", "sysinformation", "Txt_Sql_dbname")
    
     Temppath = GetSetting("databackup", "sysinformation", "txt_backup_path") + "\SqlBack" + Format(Date, "yyyy-mm-dd")
    
     On Error GoTo errhandler
   
     SqlConnectstring = "Provider=SQLOLEDB.1;Password=" + Temppasswod + ";Persist Security Info=False;User ID=" + Tempuserid + ";Initial Catalog=" + Tempdbname + ";Data Source=" + Tempservername
    
     SqlCn.ConnectionString = SqlConnectstring
        
     SqlCn.Open
    
     Frmmassage.Refresh
    
     If Err.Number <> 0 Then
        
        GoTo errhandler
        
      End If
     
      Sqlstr = "USE master"
      
      SqlCn.Execute Sqlstr
      
      Sqlstr = "EXEC sp_addumpdevice 'disk' , '" + Tempdbname + "' , '" + Temppath + "'"
      
      SqlCn.Execute Sqlstr
        
      Sqlstr = "BACKUP DATABASE " + Tempdbname + " to " + Tempdbname + " with init"
      
      SqlCn.Execute Sqlstr
      
      Sqlstr = "exec sp_dropdevice '" + Tempdbname + "'"
      
      SqlCn.Execute Sqlstr
      
      SqlCn.Close
      
      Backflag = False  '备份结束
      
      Unload Frmmassage
      
      Tempstr = "ＳＱＬ数据库备份成功。"
      
      Call writerizhi(Tempstr, Len(Tempstr))
    
      Exit Function
      
errhandler:
      
      On Error Resume Next
      
      Sqlstr = "exec sp_dropdevice '" + Tempdbname + "'"
      
      SqlCn.Execute Sqlstr
      
      SqlCn.Close
      
      Backflag = False  '备份结束

      Backflag = False
      
      Unload Frmmassage
      
      Tempstr = "ＳＱＬ数据库备份时出错！"
      
      Call writerizhi(Tempstr, Len(Tempstr))
      
   Exit Function
   
   End Function

 
 Public Function Oraclebackup()
 
 Dim Temppasswod As String
    
    Dim Tempuserid As String
    
    Dim Tempservername As String
    
    Dim Tempdbname As String
    
    Dim Temppath As String
    
    Dim Sqlstr As String
    
    
     Backflag = True
      
     Frmmassage.Show
      '备份开始
    
     Tempuserid = GetSetting("databackup", "sysinformation", "Txt_oracle_userid")
     
     If Trim(GetSetting("databackup", "sysinformation", "Txt_oracle_password")) = "" Then
     
     Temppasswod = ""
     
     Else
     
     Temppasswod = EncryptText(GetSetting("databackup", "sysinformation", "Txt_oracle_password"), "ljp")
     
     End If
     
     Tempservername = GetSetting("databackup", "sysinformation", "Txt_oracle_servername")
     
    
     Temppath = GetSetting("databackup", "sysinformation", "txt_backup_path") + "\OracleBack" + Format(Date, "yyyy-mm-dd")
    
     On Error GoTo errhandler
   
   
     OracleConnectstring = "Provider=MSDAORA.1;Password=" + Temppasswod + ";User ID=" + Tempuserid + ";Data Source=" + Tempservername + ";Persist Security Info=True"
    
     OracleCn.ConnectionString = OracleConnectstring
    
     OracleCn.Open
    
     Frmmassage.Refresh
    
     If Err.Number <> 0 Then
        
        GoTo errhandler
        
      End If
     
      i = Shell("D:\ORACLE\ORA81\BIN\EXP USERID=" + Tempuserid + "/" + Temppasswod + " FILE=" + Temppath, Normal)
    
      Tempstr = "ＯＲＡＣＬＥ数据库备份成功。"
      
      Backflag = False
      
      Unload Frmmassage
       
      Call writerizhi(Tempstr, Len(Tempstr))
      
      OracleCn.Close
    
      Exit Function
      
errhandler:
   

      Backflag = False
      
      Unload Frmmassage
      
      Tempstr = "ＯＲＡＣＬＥ数据库备份时出错！"
      
      Call writerizhi(Tempstr, Len(Tempstr))
      
      OracleCn.Close
      
   Exit Function
      
 End Function
 
 
 Public Function writerizhi(WriteStr As String, sp As Integer)
      
      Open App.Path + "\backup.log" For Append As #1

      Print #1, WriteStr + Space((16 - sp) * 2) + Format(Date, "yyyy年mm月dd日") + "   " + Format(Time, "hh时mm分ss秒") ' 将文本数据写入文件。
      
      Close #1 ' 关闭文件。

 End Function


Public Function Min_list(Str() As String, m As Integer, w As Integer) As String

Dim j, i, h As Integer

Dim Tempstr As String

For i = 1 To m

For j = 1 To m

h = DateDiff("d", CDate(Mid(Str(j), w, 10)), CDate(Mid(Str(j + 1), w, 10)))

If h < 0 Then

Tempstr = Str(j)

Str(j) = Str(j + 1)

Str(j + 1) = Tempstr

End If

Next j

Next i

End Function

Public Function Defualt_Value() As String


  SaveSetting "databackup", "sysinformation", "opthand", "False"
    
  SaveSetting "databackup", "sysinformation", "optauto", "True"
  
  SaveSetting "databackup", "sysinformation", "Chk_Autorun", "1"

  SaveSetting "databackup", "sysinformation", "OptOracle", "False"
  
  SaveSetting "databackup", "sysinformation", "OptSql", "True"
      
  SaveSetting "databackup", "sysinformation", "txt_backup_path", App.Path
  

  SaveSetting "databackup", "sysinformation", "Opt_day", "True"
  
  SaveSetting "databackup", "sysinformation", "Opt_month", "False"
  
  SaveSetting "databackup", "sysinformation", "DTP_day", Time
  
  SaveSetting "databackup", "sysinformation", "DTP_month", Time
      
  SaveSetting "databackup", "sysinformation", "Txt_month", "10"
  
  SaveSetting "databackup", "sysinformation", "Opt_week", "False"
  
  SaveSetting "databackup", "sysinformation", "DTP_week", Time
      
  SaveSetting "databackup", "sysinformation", "Txt_week", "3"


  SaveSetting "databackup", "sysinformation", "Txt_oracle_servername", ""
      
  SaveSetting "databackup", "sysinformation", "Txt_oracle_userid", ""
       
  SaveSetting "databackup", "sysinformation", "Txt_oracle_password", ""

  SaveSetting "databackup", "sysinformation", "Txt_note_day", "7"
      
  SaveSetting "databackup", "sysinformation", "Txt_note_month", "12"
  
  SaveSetting "databackup", "sysinformation", "Txt_note_week", "7"
  
  
  SaveSetting "databackup", "sysinformation", "Txt_Sql_servername", ""
      
  SaveSetting "databackup", "sysinformation", "Txt_Sql_userid", ""
      
  SaveSetting "databackup", "sysinformation", "Txt_Sql_password", ""
      
  SaveSetting "databackup", "sysinformation", "Txt_Sql_dbname", ""

End Function