VBS 保存共享文件夹到本地

'on error resume next

if GetFreeSpace ( "u:/" )<40000 then
    WriteLog "空间不足:"&GetFreeSpace ( "u:/" )&"M"
end if

DeleteOldData "E:/Documents and Settings/wangbaoming.CN-MIC/桌面/mm/新建文件夹", 3

Call NetForld( "Z:", "//FILESV/share", "wangbaoming", "30024")

Call CopyForld ( "z:/牙图片" , "E:/Documents and Settings/wangbaoming.CN-MIC/桌面/mm/新建文件夹/"&date())

'Call fZip ( "z:/牙图片", "c:/vbs.zip" )

RemoveNetForld "Z:"
'关机
Set wshshell=wscript.createobject("wscript.shell")
wshshell.run "shutdown -s -t 0"

Function GetFreeSpace(drvPath)
    Dim fso, d
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set d = fso.GetDrive(fso.GetDriveName(drvPath))
    If Err Then
        WriteLog "不能找到驱动器 “"&drvPath&"” 按确定继续",16,"错误"
        err.Clear
        GetFreeSpace = 0
        Exit Function
    End If
    GetFreeSpace = d.FreeSpace/1048576
    Set fso = Nothing
End Function

 
Function CopyForld(source, obj)
    Const OverWriteFiles = True
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.CopyFolder source, obj, OverWriteFiles
End Function

Function NetForld(drive, rpc, user, pw)
    Set WshNetwork = WScript.CreateObject("WScript.Network")
    Set WshShell = WScript.CreateObject("WScript.Shell")
    WshNetwork.MapNetworkDrive drive, rpc, FALSE, user, pw
    if err.number <>0 then
        WriteLog "WshNetwork: error number is " &cstr(err.number) & vbcrlf & _
        "error description is " & err.description
        err.clear
        Exit Function
    end if
End Function


Function RemoveNetForld(drive)
    Dim WshNetwork
    Set WshNetwork = WScript.CreateObject("WScript.Network")
    WshNetwork.RemoveNetworkDrive drive
End Function


'**********************************************
'folder zip
'**********************************************
Function fZip(sSourceFolder,sTargetZIPFile)
    'This function will add all of the files in a source folder to a ZIP file
    'using windows' native folder ZIP capability.
    Dim oShellApp, oFSO, iErr, sErrSource, sErrDescription
    Set oShellApp = CreateObject("Shell.Application")
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    'The source folder needs to have a / on the End
    If Right(sSourceFolder,1) <> "/" Then sSourceFolder = sSourceFolder & "/"
    On Error Resume Next
    'If a target ZIP exists already, delete it
    If oFSO.FileExists(sTargetZIPFile) Then oFSO.DeleteFile sTargetZIPFile,True
    iErr = Err.Number
    sErrSource = Err.Source
    sErrDescription = Err.Description
    On Error GoTo 0
    If iErr <> 0 Then
    fZip = Array(iErr,sErrSource,sErrDescription)
    Exit Function
    End If
    On Error Resume Next
    'Write the fileheader for a blank zipfile.
    oFSO.OpenTextFile(sTargetZIPFile, 2, True).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
    iErr = Err.Number
    sErrSource = Err.Source
    sErrDescription = Err.Description
    On Error GoTo 0
    If iErr <> 0 Then
    fZip = Array(iErr,sErrSource,sErrDescription)
    Exit Function
    End If
    On Error Resume Next
    'Start copying files into the zip from the source folder.
    oShellApp.NameSpace(sTargetZIPFile).CopyHere oShellApp.NameSpace(sSourceFolder).Items
    iErr = Err.Number
    sErrSource = Err.Source
    sErrDescription = Err.Description
    On Error GoTo 0
    If iErr <> 0 Then
    fZip = Array(iErr,sErrSource,sErrDescription)
    Exit Function
    End If
    'Because the copying occurs in a separate process, the script will just continue. Run a DO...LOOP to prevent the function
    'from exiting until the file is finished zipping.
    Do Until oShellApp.NameSpace(sTargetZIPFile).Items.Count = oShellApp.NameSpace(sSourceFolder).Items.Count
     WScript.Sleep 1500
    Loop
    fZip = Array(0,"","")
End Function


Function fUnzip(sZipFile,sTargetFolder)
    'Create the Shell.Application object
    Dim oShellApp:Set oShellApp = CreateObject("Shell.Application")
    'Create the File System object
    Dim oFS:Set oFSO = CreateObject("Scripting.FileSystemObject")
    'Create the target folder if it isn't already there
    If Not oFSO.FolderExists(sTargetFolder) Then oFSO.CreateFolder sTargetFolder
    'Extract the files from the zip into the folder
    oShellApp.NameSpace(sTargetFolder).CopyHere oShellApp.NameSpace(sZipFile).Items
    'This is a seperate process, so the script would continue even if the unzipping is not done
    'To prevent this, we run a DO...LOOP once a second checking to see if the number of files
    'in the target folder equals the number of files in the zipfile. If so, we continue.
    Do
    WScript.Sleep 1000
    Loop While oFSO.GetFolder(sTargetFolder).Files.Count < oShellApp.NameSpace(sZipFile).Items.Count
End Function


'写日志
Function WriteLog(data)
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    set ffile=fso.opentextfile( "vss_bak.log", 8,true)
    ffile.writeline date()&" "&time()&" : "
    ffile.writeline "    "&data
End Function

Function DeleteOldData(TargetFolder, countin)
 
     Set DosShell = createobject("wscript.shell")
     Set FSO = CreateObject("Scripting.FileSystemObject")  
     Set Folder = Fso.GetFolder(TargetFolder)  
     Set SubFolders = Folder.SubFolders
 
     dateer = date()
     filename = ""
     count = 0
     For Each SubFolder In SubFolders
         count = count + 1
         if dateer>SubFolder.DateCreated then
             dateer = SubFolder.DateCreated
             filename = SubFolder.Path
         end if
     Next
     
     if count >= countin then
         if "" <> filename then
         FSO.deletefolder filename
         end if
     end if
     
End Function