[转贴] VBS Sync 同步文件夹

' VBS 同步文件夹
' 功能：  同步文件夹，只同步已修改(或新增)的文件及文件夹，支持删除冗余(目标文件夹中存在，源文件夹不存在)文件及文件夹
' 参数：  sync.vbs  [/RD]  [/RF]  [/C]  <sourcePath>  <destinationPath>
'   sourcePath  源文件夹
'   destinationPath  目标文件夹
'   /RD 删除目标文件夹中多余的文件夹；
'   /RF 删除目标文件夹中多余的文件；
'   /C  等于同时使用 /RD /RF 参数
' 源代码下载：  http://www.robotii.co.uk/wp-content/uploads/2008/10/sync.vbs
' 个人说明：  此脚本是我使用过的同步脚本中效率及兼容性最高的。

' Download:  http://www.robotii.co.uk/wp-content/uploads/2008/10/sync.vbs
'**********************************************************************
' sync.vbs
'
' This script makes a "synchronised" backup of a folder tree from one
' path to another.
'
' Extraneous directories (folders) may be removed from the destination
' tree by specifying the /RD switch on the command line.  These are
' directories already existing in the destination tree but no longer
' found in the source tree.
'
' Extraneous files may be removed from the destination tree by specifying
' the /RF switch on the command line.  These are files which exist in
' destination directories but not in source directories.
'
' Both extraneous directories and files can be removed by specifying the
' /C switch on the command line. This switch is equivalent to specifying
' both the /RD and /RF switches
'
' Usage:  sync.vbs <sourcePath> <destinationPath>
'    or:  cscript /nologo sync.vbs <sourcePath> <destinationPath>
'    or:  wscript /nologo sync.vbs <sourcePath> <destinationPath>
'
' Notes:  Paths can use drive letters or UNC specifications.
'
'**********************************************************************
CmdMode "sync folder", "1f"

Dim oArgs
Dim TempArg
Dim bRemoveFolders
Dim bRemoveFiles
Dim SleepTime

Dim SrcFolder
Dim arrSrcFolders()
Dim s

Dim DstFolder
Dim arrDstFolders()
Dim d

Dim arrCopyFrom()
Dim arrCopyTo()
Dim arrSizes()
Dim fMax
Dim TotalSize
Dim oExplorer

Dim FSO

On Error Resume Next

  bRemoveFolders = False
  bRemoveFiles   = False
  SleepTime      = 10    ' default to leaving display onscreen for 10 seconds

  Set oArgs = WScript.Arguments
  For s = 0 To oArgs.Count - 1
    TempArg = Ucase(Left(oArgs(s),3))
    Select Case TempArg
      Case "/?"
            ShowSyntax()
            QuitScript()
            'Wscript.Quit
      Case "/S:"
            SrcFolder = Trim(Mid(oArgs(s),4))
      Case "/D:"
            DstFolder = Trim(Mid(oArgs(s),4))
      Case "/RD"
            bRemoveFolders = True
      Case "/RF"
            bRemoveFiles = True
      Case "/C"
            bRemoveFiles = True
            bRemoveFolders = True
      Case "/T:"
            SleepTime = Cint(Mid(oArgs(s),4))
            If SleepTime < 0 Then
              SleepTime = 0
            End If
      Case Else
            If Left(oArgs(s),1) <> "/" Then
              If SrcFolder = "" Then
                SrcFolder = oArgs(s)
              ElseIf DstFolder = "" Then
                DstFolder = oArgs(s)
              Else
                Wscript.Echo "Unknown parameter on command line... " & oArgs(s)
                ShowSyntax()
                QuitScript()
                'Wscript.Quit
              End If
            End If
    End Select
  Next

  If SrcFolder = "" or DstFolder = "" Then
    Wscript.Echo "You must enter a 'SourcePath' and 'DestinationPath' when starting this script."
    ShowSyntax()
    QuitScript()
    'Wscript.Quit
  Else
    echo "Source      : " & SrcFolder & VbCrLf & _
         "Destination : " & DstFolder & VbCrLf
  End If

  If Right(SrcFolder,1) <> "\" Then
    SrcFolder = SrcFolder & "\"
  End If

  If Right(DstFolder,1) <> "\" Then
    DstFolder = DstFolder & "\"
  End If

  If InStr(LCase(SrcFolder),LCase(DstFolder)) > 0 _
  Or InStr(LCase(DstFolder),LCase(SrcFolder)) > 0  Then
    Wscript.Echo "The 'SourcePath' and 'DestinationPath' cannot overlap!"
    Wscript.Quit
  End If

  TotalSize = 0

  Set FSO = CreateObject("Scripting.FileSystemObject")
  'Set oExplorer = CreateObject("InternetExplorer.Application")

  'oExplorer.Navigate2 "about:blank"
  'oExplorer.Width     = 550
  'oExplorer.Height    = 300
  'oExplorer.Top       = 300
  'oExplorer.Left      = 300
  'oExplorer.Toolbar   = False
  'oExplorer.Menubar   = False
  'oExplorer.Statusbar = False
  'oExplorer.Visible   = True

  'oExplorer.Document.Write "<font face=Verdana>"
  'oExplorer.Document.Write "<h2>File Backup in Progress</h2>"
  'oExplorer.Document.Write "<p>Beginning backup...<br>"
  'oExplorer.Document.Title = "Please be patient.... "
  
  echo "File Backup in Progress" & VbCrLf
  echo "Beginning backup..." & VbCrLf
  echo "Please be patient.... " & VbCrLf

  GetSrcInfo
  GetDstInfo
  CreateMissingFolders
  If bRemoveFolders Then
    DeleteExtraFolders
  End If
  If bRemoveFiles Then
    DeleteExtraFiles
  End If
  FindFilesNeedingBackup
  CopySourceToDest
  
  'oExplorer.document.write "<font color=red>"
  'oExplorer.Document.Write "  Finished!<br>"
  
  echo "Finished!" & VbCrLf
  QuitScript()

Sub GetSrcInfo()
  'oExplorer.Document.Write "Analyzing source directories...<br>"
  echo "Analyzing source directories..." & VbCrLf
  '-- get information about source directories
  If FSO.FolderExists(SrcFolder) Then
    ReDim arrSrcFolders(100)
    s = 0
    arrSrcFolders(0) = Left(SrcFolder, Len(SrcFolder) - 1)
    GetSrcFolders FSO.GetFolder(SrcFolder)
    ReDim Preserve arrSrcFolders(s)
  Else
    Wscript.Echo "Source folder not found... aborting."
    QuitScript()
  End If
End Sub

Sub GetSrcFolders(Folder)
  Dim Subfolder
  For Each Subfolder In Folder.SubFolders
    s = s + 1
    If s > Ubound(arrSrcFolders) Then
      ReDim Preserve arrSrcFolders(Ubound(arrSrcFolders) + 100)
    End If
    arrSrcFolders(s) = SubFolder.Path
    GetSrcFolders Subfolder
  Next
End Sub

Sub GetDstInfo()
  'oExplorer.Document.Write "Analyzing backup directories...<br>"
  echo "Analyzing backup directories..." & VbCrLf
  '-- get information about destination directories
  If Not FSO.FolderExists(DstFolder) Then
    CreateMultiLevelFolder DstFolder
  End If
  ReDim arrDstFolders(100)
  d = 0
  arrDstFolders(0) = Left(DstFolder, Len(DstFolder) - 1)
  GetDstFolders FSO.GetFolder(DstFolder)
  ReDim Preserve arrDstFolders(d)
End Sub

Sub CreateMultiLevelFolder(FolderPath)
Dim TempPath
Dim Path
Dim arrNodes
Dim n

  TempPath = FolderPath
  Path = ""

  ' See if input is in UNC format...
  If Instr(TempPath,"\\") > 0 Then
    TempPath = Mid(TempPath,3)
    n = Instr(TempPath,"\")
    Path = "\\" & Left(TempPath,n)
    TempPath = Mid(TempPath,n+1)
  End If

  arrNodes = Split(TempPath,"\")
  Path     = Path & arrNodes(0)

  For n = 1 To UBound(arrNodes)
    Path = Path & "\" & arrNodes(n)
    If Not FSO.FolderExists(Path) Then
      FSO.CreateFolder(Path)
    End If
  Next
End Sub

Sub GetDstFolders(Folder)
  Dim Subfolder
  For Each Subfolder In Folder.SubFolders
    d = d + 1
    If d > Ubound(arrDstFolders) Then
      ReDim Preserve arrDstFolders(Ubound(arrDstFolders) + 100)
    End If
    arrDstFolders(d) = SubFolder.Path
    GetDstFolders Subfolder
  Next
End Sub

Sub CreateMissingFolders()
  Dim LenOfSrcBaseDir
  Dim strFolder, f

  'oExplorer.Document.Write "Creating any missing backup directories...<br>"
  echo "Creating any missing backup directories..." & VbCrLf
  
  LenOfSrcBaseDir = Len(SrcFolder) + 1

  For f = 0 to s
    strFolder = DstFolder & Mid(arrSrcFolders(f), LenOfSrcBaseDir)
    If Not FSO.FolderExists(strFolder) Then
      FSO.CreateFolder(strFolder)
    End IF
  Next
End Sub

Sub DeleteExtraFolders()
  Dim LenOfDstBaseDir
  Dim strFolder, f

  'oExplorer.Document.Write "Removing any extra backup directories...<br>"
  echo "Removing any extra backup directories..." & VbCrLf
  
  LenOfDstBaseDir = Len(DstFolder) + 1

  For f = 0 To d
    strFolder = SrcFolder & Mid(arrDstFolders(f), LenOfDstBaseDir)
    If (Not FSO.FolderExists(strFolder)) Then
      FSO.DeleteFolder arrDstFolders(f),True
    End IF
  Next
End Sub

Sub DeleteExtraFiles()
  Dim LenOfSrcBaseDir
  Dim LenOfDstBaseDir
  Dim strDstFolder
  Dim strDstFile
  Dim strSrcFile
  Dim oFldr, oFile
  Dim fc, f

  'oExplorer.Document.Write "Removing any extra backup files...<br>"
  echo "Removing any extra backup files..." & VbCrLf

  LenOfSrcBaseDir = Len(SrcFolder) + 1
  LenOfDstBaseDir = Len(DstFolder) + 1

  For f = 0 to s
    strDstFolder = DstFolder & Mid(arrSrcFolders(f), LenOfSrcBaseDir)
    set fc = FSO.GetFolder(strDstFolder).Files
    For Each oFile In fc
      strDstFile = strDstFolder & IIf(f = 0, "", "\") & oFile.Name
      strSrcFile = SrcFolder & Mid(strDstFile, LenOfDstBaseDir)
      If (Not FSO.FileExists(strSrcFile)) And FSO.FileExists(strDstFile) Then
        FSO.DeleteFile strDstFile,True
      End If
    Next
  Next
  Set fc    = Nothing
End Sub

Sub FindFilesNeedingBackup()
  Dim LenOfSrcBaseDir
  Dim strFrom
  Dim strTo, f, fc, oFile

  'oExplorer.Document.Write "Determining which files to backup...<br>"
  echo "Determining which files to backup..." & VbCrLf
  
  ReDim arrCopyFrom(100)
  ReDim arrCopyTo(100)
  ReDim arrSizes(100)
  fMax = -1
  LenOfSrcBaseDir = Len(SrcFolder) + 1
  arrSrcFolders(0) = SrcFolder
  arrDstFolders(0) = DstFolder

  For f = 0 To s
    Set fc = FSO.GetFolder(arrSrcFolders(f)).Files
    For Each oFile In fc
      strFrom = arrSrcFolders(f) & "\" & oFile.Name
      strTo   = DstFolder & Mid(strFrom, LenOfSrcBaseDir)
      If Not FSO.FileExists(strTo) Then
        AddToList strFrom, strTo, oFile.Size
      Else
        Set oDstFile = FSO.GetFile(strTo)
        If FileIsNewer(oFile, oDstFile) Then
          AddToList strFrom, strTo, oFile.Size
        End If
      End If
    Next
  Next
  Set fc = Nothing
End Sub

Function FileIsNewer(Source, Dest)
  FileIsNewer = False
  If Source.DateLastModified > Dest.DateLastModified Then
    FileIsNewer = True
  End If
End Function

Sub AddToList(strFrom, strTo, FileSize)
  Dim fCur
  fCur = Ubound(arrCopyFrom)
  fMax = fMax + 1
  if fMax > fCur Then
    ReDim Preserve arrCopyFrom(fCur + 100)
    ReDim Preserve arrCopyTo(fCur + 100)
    ReDim Preserve arrSizes(fCur + 100)
  End If
  arrCopyFrom(fMax) = strFrom
  arrCopyTo(fMax)   = strTo
  arrSizes(fMax)    = FileSize
  TotalSize         = TotalSize + FileSize
End Sub

Sub CopySourceToDest()
  Dim CurPercent, TotalCopied, myProgressIndicator, f
  TotalCopied = 0

  If fMax > -1 Then
    If fMax = 0 Then
      'oExplorer.Document.Write "Backing up 1 file...<br>"
      echo "Backing up 1 file..." & VbCrLf
    Else
      'oExplorer.Document.Write "Backing up " & fMax + 1 & " files...<br>"
      echo "Backing up " & fMax + 1 & " files... "
    End If

    'oexplorer.document.write "<div id='ProgressIndicator' style='background-color:blue;text-align:center; color:white;'></div>"
    'Set myProgressIndicator = oExplorer.Document.All("ProgressIndicator")

    For f = 0 To fMax
      echo String(Len(CurPercent), Chr(8))
      If FSO.FileExists(arrCopyTo(f)) Then
        FSO.DeleteFile arrCopyTo(f), True
      End If
      FSO.CopyFile arrCopyFrom(f), arrCopyTo(f)
      TotalCopied = TotalCopied + arrSizes(f)
      CurPercent  = CStr(Round(100 * TotalCopied / TotalSize)) & "%"
      ' Set the current progress indicator
      'myProgressIndicator.innerHTML = CurPercent
      'myProgressIndicator.style.width = CurPercent
      echo CurPercent
    Next
    echo VbCrLf
  Else
    'oExplorer.Document.Write "No files need to be backed up...<br>"
    echo "No files need to be backed up..." & VbCrLf
  End If
End Sub

Function IIf( expr, truepart, falsepart )
  If expr Then
    IIf = truepart
  Else
    IIf = falsepart
  End If
End Function

Sub QuitScript()
  'oExplorer.Quit
  'Set oExplorer = Nothing
  Set FSO       = Nothing
  
  If SleepTime = "" Then
    Pause " > Press enter to quit ... "
  Else
  'If SleepTime > 0 Then
    Wscript.Sleep (SleepTime * 1000)
  End If
  
  Wscript.Quit
End Sub

Sub ShowSyntax()
  Wscript.Echo "Sync.vbs [/S:]<source> [/D:]<destination> [/RD] [/RF] [/C] [/T:<num>]          "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  All switches are case insensitive as well as 'order insensitive'.  Directory "
  Wscript.Echo "  names with embedded spaces are supported either with or without surrounding  "
  Wscript.Echo "  quotes (single or double), however, if they contain multiple adjacent spaces "
  Wscript.Echo "  they must be quoted.  Spaces after the ':' are ignored.                      "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  /RD specifies to remove extraneous directories (folders) from the            "
  Wscript.Echo "      destination path if found.                                               "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  /RF specifies to remove extraneous files from the destination path if found. "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  /C  Equivalent to specifying /RD and /RF on the command line.                "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  /T:<num> Optional switch to specify number of seconds to leave final         "
  Wscript.Echo "           screen display visible. Defaults to 10 seconds if not specified.    "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  The /S: and /D: switches are optional.  When not used, the first parameter   "
  Wscript.Echo "  on the command line not preceded by '/' will be taken as the source path and "
  Wscript.Echo "  the second parameter not preceded by '/' will be taken as the destination    "
  Wscript.Echo "  path.                                                                        "
  Wscript.Echo "                                                                               "
  Wscript.Echo "  The use of the '-' character in lieu of '/' is not supported.                "
  Wscript.Echo "                                                                               "
End Sub


' ====================================================================================================
' CMD 命令集
' ----------------------------------------------------------------------------------------------------
' ----------------------------------------------------------------------------------------------------
' 强制以命令行模式运行
Function CmdMode(ByVal title,ByVal color)
    If LCase(Right(WScript.FullName,11))="wscript.exe" Then
        Set oArgs = WScript.Arguments
        For s = 0 To oArgs.Count - 1
            strArgs = strArgs & " """ & Trim(oArgs(s)) & """ "
        Next
        With CreateObject("Wscript.Shell")
            .Run "cmd /c title "&title&"&color "&color&"&Cscript //Nologo """ & WScript.ScriptFullName & """ " & strArgs, 1, False
            '.Run "taskkill /f /im cmd.exe",0
        End With
        WScript.Quit
    End If
End Function
' 检测是否运行于CMD模式
Function IsCmdMode()
    IsCmdMode = False
    If (LCase(Right(WScript.FullName,11)) = LCase("CScript.exe")) Then IsCmdMode = True
End Function
' 获取CMD输出
Function CmdOut( ByVal strCmd)
    If IsCmdMode() = False Then Exit Function
    Set ws = CreateObject("WScript.Shell")
    Set oexec = ws.Exec( strCmd )
    pid = oExec.ProcessId
    CmdOut = oExec.StdOut.ReadAll
End Function
' 输出消息
Sub Echo( ByVal strOutput )
    If (LCase(Right(WScript.FullName,11)) = LCase("CScript.exe")) Then
		WScript.StdOut.Write strOutput
    End If
End Sub
' 暂停函数
Function Pause( ByVal strMsg )
    If (LCase(Right(WScript.FullName,11)) = LCase("CScript.exe")) Then
        WScript.StdOut.Write VbCrLf & strMsg
        Pause = WScript.StdIn.ReadLine
    End If
End Function
' 读取输入，相当于Set/p p=
Function ReadInput( ByVal strEnquiry )
	If IsCmdMode() = True Then
        WScript.StdOut.Write strEnquiry
        ReadInput = Trim( WScript.StdIn.ReadLine )
    Else
        ReadInput = Trim( Inputbox( strEnquiry, "请输入：", "" ) )
    End If
End Function
复制代码

'On Error Resume Next

' 取得当前路径
Dim MeDir, MeName
MeDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\")-1)                                ' 脚本所在文件夹路径


' 检测是否重复运行
If MeIsAlreadyRun() = True Then
    REM CreateObject("WScript.Shell").popup VbCrLf & "程序 " & AppFile & " 已运行。　　　　" & VbCrLf, 1, "提示", 0+48
    WScript.Quit(999)
End If

' 是否使用脚本所在目录作为源
Dim choice
choice = msgbox( VbCrLf & "来源文件夹：" & MeDir & " (本程序位置)　　" & VbCrLf & VbCrLf & "是否确认？" & VbCrLf & VbCrLf, _
                vbYesNoCancel + 64, _
                "文件夹同步 - Foler Sync")
Select Case choice
    Case vbYes
        folder_src = MeDir
        folder_des = BrowseFolder(  "来源文件夹：" & folder_src & VbCrLf & _
                                    "目标文件夹：请选择一个目标文件夹的位置" _
                                    , "", True )
        If folder_des = "" Then QuitScript(1001)
    Case vbNo
        folder_src = BrowseFolder( "来源文件夹：请选择一个来源文件夹的位置" & VbCrLf _
                                  , "", True )
        If folder_src = "" Then QuitScript(1002)
        folder_des = BrowseFolder( "来源文件夹：" & folder_src & VbCrLf & _
                                    "目标文件夹：请选择一个目标文件夹的位置" _
                                    , "", True )
        If folder_des = "" Then QuitScript(1003)
    Case vbCancel
        QuitScript(1004)
End Select

' 确认同步
choice = msgbox( VbCrLf & "来源文件夹： " & folder_src & "　　" & VbCrLf & VbCrLf & _
                    "　同步至　　" & VbCrLf & VbCrLf & _
                    "目标文件夹： " & folder_des & "　　" & VbCrLf & VbCrLf & VbCrLf &  _
                    "是否确认？" & VbCrLf, _
                vbYesNoCancel + 64, _
                "文件夹同步 - Foler Sync")
If Not choice = vbYes Then QuitScript(1005)


' 打开同步脚本 .\sync.vbs
CreateObject("WScript.Shell").Run """" & MeDir & "\sync.vbs"" """ & folder_src & """ """ & folder_des & """ ""/C""" , 1, False

' 退出
QuitScript(0)



' 退出程序
Function QuitScript(ErrorNum)
    WScript.Quit(ErrorNum)
End Function



' 检测自身是否重复运行
Function MeIsAlreadyRun()
    MeIsAlreadyRun = False
    If (IsRun(LCase(Right(WScript.FullName,11)), WScript.ScriptFullName) > 1) Then MeIsAlreadyRun = True
End Function

' 检测是否运行
Function IsRun(byVal AppName, byVal AppPath)   ' Eg: Call IsRun("mshta.exe", "c:\test.hta")
    IsRun = 0 : i = 0
    For Each ps in GetObject("winmgmts:\\.\root\cimv2:win32_process").instances_
        IF LCase(ps.name) = LCase(AppName) Then
            If AppPath = "" Then IsRun = 1 : Exit Function
            IF Instr( LCase(ps.CommandLine) , LCase(AppPath) ) Then i = i + 1
        End IF
    Next
    IsRun = i
End Function


' http://www.robvanderwoude.com/vbstech_ui_browsefolder.php
' BrowseFolder( "源文件夹：请选择一个来源文件夹的位置", "D:\", True )
Function BrowseFolder( strPrompt, myStartLocation, blnSimpleDialog )
 ' This function generates a Browse Folder dialog
 ' and returns the selected folder as a string.
 '
 ' Arguments:
 ' myStartLocation   [string]  start folder for dialog, or "My Computer", or
 '                             empty string to open in "Desktop\My Documents"
 ' blnSimpleDialog   [boolean] if False, an additional text field will be
 '                             displayed where the folder can be selected
 '                             by typing the fully qualified path
 '
 ' Returns:          [string]  the fully qualified path to the selected folder
 '
 ' Based on the Hey Scripting Guys article
 ' "How Can I Show Users a Dialog Box That Only Lets Them Select Folders?"
 ' http://www.microsoft.com/technet/scriptcenter/resources/qanda/jun05/hey0617.mspx
 '
 ' Function written by Rob van der Woude
 ' http://www.robvanderwoude.com
     Const MY_COMPUTER   = &H11&
     Const WINDOW_HANDLE = 0 ' Must ALWAYS be 0

     Dim numOptions, objFolder, objFolderItem
     Dim objPath, objShell, strPath ', strPrompt

     ' Set the options for the dialog window
     'strPrompt = "Select a folder:"
     If blnSimpleDialog = True Then
         numOptions = 0      ' Simple dialog
     Else
         numOptions = &H10&  ' Additional text field to type folder path
     End If
     
     ' Create a Windows Shell object
     Set objShell = CreateObject( "Shell.Application" )

     ' If specified, convert "My Computer" to a valid
     ' path for the Windows Shell's BrowseFolder method
     If UCase( myStartLocation ) = "MY COMPUTER" Then
         Set objFolder = objShell.Namespace( MY_COMPUTER )
         Set objFolderItem = objFolder.Self
         strPath = objFolderItem.Path
     Else
         strPath = myStartLocation
     End If

     Set objFolder = objShell.BrowseForFolder( WINDOW_HANDLE, strPrompt, _
                                               numOptions, strPath )

     ' Quit if no folder was selected
     If objFolder Is Nothing Then
         BrowseFolder = ""
         Exit Function
     End If

     ' Retrieve the path of the selected folder
     Set objFolderItem = objFolder.Self
     objPath = objFolderItem.Path

     ' Return the path of the selected folder
     BrowseFolder = objPath
 End Function
复制代码