发个WINDOWS下用Email附件备份数据VBS脚本

Neta

前几天有个哥们Windows下的MYSQL数据库被未知生物袭击了
清空了所有的内容 然后删除了所有的库
用数据恢复软件恢复出来的 都是空表
那哥们可是欲哭无泪啊...

然后就让我帮忙搞个备份功能....
记得论坛里发过一个Linux下用邮箱附件备份数据的软件 就想照这功能写个Win下的
本人不才 没学过VBScript 不当之处 欢迎指出
是先先rar打包 再发送
压缩包里的rar.exe 可以在您的WinRAR根目录里找到.. 当前貌似3.93版

1. '-----------------------------------------------------------------------------------
   
2. 
   
3. '应用程序配置项↓
   
4. 
   
5. '-----------------------------------------------------------------------------------
   
6. 
   
7. '数据库目录 (目录均以"" 结尾)
   
8. Const MySqlDataDir = "C:\Users\Neta\Desktop\Data"
   
9. '备份数据库目录
   
10. Const MySqlBackupDir = "C:\Users\Neta\Desktop"
    
11. 'RAR压缩程序文件路径
    
12. Const RarExePath = "rar.exe"
    
13. '发件邮箱
    
14. Const EmailFrom = "send@qq.com"
    
15. '收件邮箱 推荐网易邮箱
    
16. Const EmailTo = "receive@163.com"
    
17. 'SMTP地址
    
18. Const SmtpServer = "smtp.qq.com"
    
19. 'SMTP端口
    
20. Const SmtpServerPort = 25
    
21. 'SMTP发信登陆帐号
    
22. Const SendUserName = "send@qq.com"
    
23. 'SMTP发信登陆密码
    
24. Const SendPassWord = "password"
    
25. '发送完毕是否删除备份数据文件 true | false
    
26. Const DeleteFile = true
    
27. '单个附件大小 单位为MB
    
28. Const AttachmentSize = 30
    
29. 
    
30. '---------------------------------------------------------------------------------------
    
31. '其他说明: 当执行RAR压缩的时候 会出现一个命令行窗口 显示压缩过程 请勿关闭!
    
32. '---------------------------------------------------------------------------------------
    
33. backupDateTime = now()
    
34. backupFileName = GetName(backupDateTime)
    
35. 
    
36. 
    
37. attach = MySqlBackupDir & backupFileName & ".rar"
    
38. 
    
39. '开始备份
    
40. Set WshShell = CreateObject("WScript.Shell")
    
41. Set fso = CreateObject("Scripting.FileSystemObject")
    
42. WshShell.run RarExePath & " a -ibck " & attach & " " & MySqlDataDir,,true
    
43. 
    
44. Set backupFile = fso.GetFile(attach)
    
45. 
    
46. '判断附件大小 如果超过AttachmentSize  则进行分卷打包
    
47. IF backupFile.Size > AttachmentSize * 1024 * 1024 Then
    
48. 
    
49.   '计算分卷打包文件个数
    
50.   TotalFile = GetInteger(backupFile.Size / (AttachmentSize * 1024 * 1024))
    
51.   
    
52.   '重新取得文件打包时间
    
53.   backupDateTime = now()
    
54.   backupFileName = GetName(backupDateTime)
    
55.   
    
56.   '开始分卷打包
    
57.   WshShell.run RarExePath & " a -v" & AttachmentSize & "m -ibck " & MySqlBackupDir & backupFileName & " " & attach,,true
    
58.   
    
59.   '删除初次打包的文件
    
60.   Call DelFile(attach)
    
61.   
    
62.   '发送分卷
    
63.   For P = 1 To TotalFile
    
64.     attach = MySqlBackupDir & backupFileName & ".part" & P & ".rar"
    
65.     Call SendMail(attach,backupDateTime)
    
66.   Next
    
67.   
    
68. Else
    
69.   Call SendMail(attach,backupDateTime)
    
70. End IF
    
71. 
    
72. 
    
73. Set WshShell = Nothing
    
74. Set fso = Nothing
    
75. 
    
76. Function GetName(time)
    
77.         GetName = Replace(Replace(Replace(time, "/", "-"), " ", "-"), ":", "-")
    
78. End Function
    
79. 
    
80. Function GetInteger(number)
    
81.         GetInteger = int(number)
    
82.         IF GetInteger < number Then
    
83.                 GetInteger = GetInteger + 1
    
84.         End IF
    
85. End Function
    
86. 
    
87. Sub DelFile(path)
    
88.         IF deleteFile Then
    
89.           fso.DeleteFile(path)
    
90.         End IF
    
91. End Sub
    
92. 
    
93. Sub SendMail(file,time)
    
94.         NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
    
95.         set Email = CreateObject("CDO.Message")
    
96. 
    
97.         Email.From = EmailFrom
    
98.         Email.To = EmailTo
    
99.         Email.Subject = "MYSQL BACKUP : " & time
    
100. 
     
101.         Email.Textbody = "这个是数据库备份文件,备份于: " & time
     
102.         Email.AddAttachment file
     
103. 
     
104.         With Email.Configuration.Fields
     
105.           .Item(NameSpace&"sendusing") = 2
     
106.           .Item(NameSpace&"smtpserver") = SmtpServer
     
107.           .Item(NameSpace&"smtpserverport") = SmtpServerPort
     
108.           .Item(NameSpace&"smtpauthenticate") = 1
     
109.           .Item(NameSpace&"sendusername") = SendUserName
     
110.           .Item(NameSpace&"sendpassword") = SendPassWord
     
111.           .Update
     
112.         End With
     
113. 
     
114.         Email.Send
     
115.         Set Email = Nothing
     
116.        
     
117.         Call DelFile(file)
     
118. End Sub

复制代码

[ 本帖最后由 Neta 于 2010-10-6 19:44 编辑 ]

usa

不错。。。

Neta

  usa 真是极速 我还没编辑完沙发就没了...

sunday

好帖还是要支持支持

drivel

支持一下

jimmy0017

支持一下！

press

不错。收藏一个！

小夜

好贴，要给分。

Captain

WScript.Shell
必须开着，有一定安全风险

zrdlrofmine

支持