' VB Script Document
'植物大战僵尸泳池无尽记录备份工具v1.0
'本程序在windows7上测试通过
'《植物大战僵尸》存档位置:
'xp用户
'默认在 plants vs zombies游戏目录 userdata
'vista操作系统以上用户
'默认在 C:ProgramData/PopCap Games/PlantsVsZombie/userdata
'******************************************
'* *
'* 作者:zy3364432@qq.com *
'* *
'******************************************
Set ws= WScript.CreateObject("WScript.Shell")
Dim Path,WS,SaveDataName,BackupDataName,BackupFolderName,fso,Choice
Path="C:/ProgramData/PopCap Games/PlantsVsZombies/userdata/"
BackupFolderName="泳池无尽版记录备份"
BackupDataPath=Path & BackupFolderName & "/"
SaveDataName="game1_13.dat"
BackupDataName="game1_13" & year(Date) & "年" & month(Date) & "月" & day(Date) & "日" & hour(Time) & "时" & minute(Time) & "分" & second(Time) & "秒" & ".dat"
Choice=inputbox("请输入要进行的操作:" & vbcrlf & vbcrlf & _
"[1].备份当前记录" & vbcrlf & _
"[2].还原已备份记录点" & vbcrlf & _
"[3].删除记录点" & vbcrlf & _
"[4].查看记录点" & vbcrlf & _
"[5].打开记录点文件夹"_
,"操作选择",1)
If Choice<>"" Then
Select Case Choice
case 1:Backup()
case 2:RestoreFile()
case 3:Remove()
case 4:msgbox ShowFiles(ReturnAllFiles(BackupDataPath)),,"共" & UBound(ReturnAllFiles(BackupDataPath))+1 & "条记录"
case 5:WS.run "explorer " & BackupDataPath
case else:msgbox "作者:zy3364432@qq.com",vbExclamation
End Select
End if
'**********************************************************************************************************************************************************
Sub Backup()'备份子程序段
If CheckFile(Path,SaveDataName) and CheckFolder(Path,BackupFolderName) Then
CopyFile Path,BackupDataPath,SaveDataName,BackupDataName
If CheckFile(BackupDataPath,BackupDataName) Then
msgbox "记录备份成功!" & vbcrlf & BackupDataName,,"成功"
Else
msgbox "记录备份失败!",,"失败"
End if
End if
End Sub
'**********************************************************************************************************************************************************
Function CopyFile(FromPath,ToPath,SourceFileName,SaveFileName)'复制文件子程序
Set fso=WScript.CreateObject("scripting.filesystemobject")
fso.copyFile FromPath & SourceFileName,ToPath & SaveFileName
Set fso=Nothing
if err.number>0 then
msgbox err.Description
else
CopyFile=true
end if
End Function
'**********************************************************************************************************************************************************
Function CheckFile(FilePath,FileName)'检查文件是否存在
Dim ReturnValue
Set fso=CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FilePath & FileName) Then'判断文件是否存在
ReturnValue=True
Else
ReturnValue=False
msgbox "不存在" & FilePath & FileName,,"错误"
End If
Set fso=Nothing
CheckFile=ReturnValue'存在返回真
End Function
'**********************************************************************************************************************************************************
Function CheckFolder(FolderPath,FolderName)'检查文件夹是否存在
Dim ReturnValue
Set fso=CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolderPath & FolderName) Then'判断文件夹是否存在
ReturnValue=True
Else
ReturnValue=False
if msgbox("不存在" & FolderPath & FolderName & vbcrlf &"是否创建备份文件夹?",vbYesNO,"文件夹不存在")=6 then'点击是则返回6点否返回7
fso.CreateFolder(FolderPath & FolderName)'创建文件夹
ReturnValue=True
End if
End If
Set fso=Nothing
CheckFolder=ReturnValue'存在返回真
End Function
'*********************************************************************************************************************************************************
Function ReturnAllFiles(path)'返回一个保存文件名的数组
dim allfolders
dim allfiles
dim files
dim count
dim FilesArray()
set fso=WScript.CreateObject("scripting.filesystemobject")
set allfolders=fso.getfolder(path)'创建文件夹对象
set allfiles=allfolders.files'获得文件对象
for each files in allfiles
count=count+1
next
Redim FilesArray(count-1)
count=0
for each files in allfiles
FilesArray(count)=files.name'输出文件名到数组
count=count+1
next
set allfiles=nothing
set allfolders=nothing
set fso=nothing
ReturnAllFiles=FilesArray
End function
'*******************************************************************************************************************************************************
Function ShowFiles(ByVal ShowArray())'显示数组内容
dim i,FileNames
for i=LBound(ShowArray) to UBound(ShowArray)
FileNames=FileNames & vbcrlf & "[" & CStr(i) & "]." & Mid(Left(ShowArray(i),Len(ShowArray(i))-4),9)
next
ShowFiles=FileNames
End Function
'*******************************************************************************************************************************************************
Sub RestoreFile()
Dim ChooseNumber
FileList=ReturnAllFiles(BackupDataPath)'将文件名数组赋值给FileList
ChooseNumber=inputbox("请输入要还原的时间点的序号:" & vbcrlf & ShowFiles(FileList),"还原记录",UBound(FileList))
If ChooseNumber>=Cstr(LBound(FileList)) and ChooseNumber<=Cstr(UBound(FileList)) Then
DeleteFile Path,SaveDataName
If CopyFile(BackupDataPath,Path,FileList(ChooseNumber),SaveDataName) then
msgbox "记录还原成功!" & vbcrlf & "记录名为:" & FileList(ChooseNumber),,"成功"
Else
msgbox "记录还原失败!",,"失败"
End if
Elseif ChooseNumber="" then
WScript.quit
Else
msgbox "输入错误!",vbExclamation,"错误"
End if
End Sub
'*******************************************************************************************************************************************************
Function DeleteFile(DeleteFilePath,DeleteFileName)
Dim ReturnValue,DeletePath
DeletePath=DeleteFilePath & DeleteFileName
Set fso=WScript.CreateObject("scripting.filesystemobject")
If fso.FileExists(DeletePath) Then
fso.DeleteFile(DeletePath)
ReturnValue=True
Else
ReturnValue=False
End if
Set fso=Nothing
DeleteFile=ReturnValue
End Function
'******************************************************************************************************************************************************
Sub Remove()
Dim ChooseNumber
FileList=ReturnAllFiles(BackupDataPath)'将文件名数组赋值给FileList
ChooseNumber=inputbox("请输入要删除的还原的时间点的序号:" & vbcrlf & ShowFiles(FileList),"还原记录",LBound(FileList))
If ChooseNumber>=Cstr(LBound(FileList)) and ChooseNumber<=Cstr(UBound(FileList)) Then
If DeleteFile(BackupDataPath,FileList(ChooseNumber)) then
msgbox "记录删除成功!" & vbcrlf & "记录名为:" & FileList(ChooseNumber),,"成功"
Else
msgbox "记录删除失败!",,"失败"
End if
Elseif ChooseNumber="" then
WScript.quit
Else
msgbox "输入错误!",vbExclamation,"错误"
End if
End Sub
Set WS=nothing
WScript.quit
将以上代码用记事本保存成 无尽记录备份工具.vbs
尽情挑战无尽泳池的乐趣吧。
注:目前只支持windows7