'--------------------------------------------------------------------
' Various initialisations. These are the only things that you need
' to look at and possibly change.
'--------------------------------------------------------------------

unpromptedDestination = "E:\"

promptForFolder = false ' true -> BrowseForFolder dialog will open
replicatePath   = true  ' true -> the full source path is replicated
noConfirmation  = true  ' true -> prevent questions during file copying
newName         = true  ' true -> prevent copying over existing files

'--------------------------------------------------------------------
' BackBurner.vbs
' Richard A. DeVenezia, 06/10/2003
' http://www.devenezia.com/contact.php
'
' Send me some mail if you find this useful.
'
' Purpose: Copy from source to destination,
' replicating the path to the source in the destination
'
' Anticipated use:
' 1. Place this script in your Send To folder
' 2. In Explorer highlight one or more files and folders,
'    right click over selection and choose SendTo -> BackBurner.vbs
'
' Updated
' 10mar05 - Use CopyHere so animated progress will be shown
'           when large amounts of copying are occurring.
'
' 07jul05 - By Nick Carter (NickCarter[dot]RMC[at]gmail[dot]com).
'           Use variable replicatePath to control whether full source path
'           is replicated or not.
'           Use variable copyFlags to hold CopyHere flags:
'           noConfirmation and newName.

BIF_RETURNONLYFSDIRS = &H0001
BIF_EDITBOX = &H0010
BIF_VALIDATE = &H0020
BIF_NEWDIALOGSTYLE = &H0040

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Dim ws
Set ws = CreateObject("WScript.Shell")

Dim oShell
Set oShell = CreateObject("Shell.Application")

if promptForFolder then

  '--------------------------------------------------------------------
  ' Obtain destination root from user
  '--------------------------------------------------------------------

  Dim oFolder
  Set oFolder = oShell.BrowseForFolder _
    ( _
      &H0, _
      "Select the folder where the backup should go." & vbCrLf & _
      "Note: Clicking OK after typing in a new folder path will create the folder.", _
      BIF_NEWDIALOGSTYLE + BIF_validate + BIF_Editbox + BIF_RETURNONLYFSDIRS _
    )

  if oFolder is Nothing then wscript.Quit(0)

  ' Get absolute path of folder,
  ' technique is from atx post to microsoft.public.scripting.vbscript on 19Jan05

  Set oFolderItem = oFolder.Items.Item

  if oFolderItem is Nothing then
     Set oFolderItem = fso.GetFolder (ws.SpecialFolders (oFolder&""))
  end if

  destinationRoot = oFolderItem.path

  if not fso.FolderExists (destinationRoot) then
    msgbox oFolder & " is not a place for backups"
    wscript.Quit(0)
  end if

else

  destinationRoot = unpromptedDestination

end if

'--------------------------------------------------------------------
' Create the destination root if necessary
' Should never be necessary if BrowseForFolder used to obtain path.
'--------------------------------------------------------------------

Dim parts
Dim destinationRootPath

parts = Split (destinationRoot, "\", -1, 1)

for i = lbound(parts) to ubound(parts)
  if parts(i) <> "" then
    destinationRootPath = destinationRootPath & parts(i) & "\"

    if (not fso.FolderExists (destinationRootPath)) then
      fso.CreateFolder (destinationRootPath)
    end if
  end if
next

'--------------------------------------------------------------------
' Each argument is a file or folder selected for Send To processing.
'--------------------------------------------------------------------

Dim count
Dim msg

count = 0
msg = ""

for each arg in wscript.arguments

  destinationPath = destinationRootPath

  if replicatePath then
    '------------------------------------------------------------------
    ' Create a replicate path to arg in the destination root
    '------------------------------------------------------------------
    parts = Split (arg, "\", -1, 1)
    for i = lbound(parts) to ubound(parts)-1
      if parts(i) <> "" and not (InStr (parts(i), ":" ) > 0) then
         destinationPath = destinationPath  & parts(i) & "\"
         if (not fso.FolderExists (destinationPath)) then
           fso.CreateFolder (destinationPath)
         end if
      end if
    next
  end if

  Dim oDestination
  Set oDestination = oShell.NameSpace ( destinationPath )

  '--------------------------------------------------------------------
  ' Set the flags for the CopyHere function
  ' 16: with no confirmation
  '  8: give a new name if file already exists
  '--------------------------------------------------------------------

  copyFlags=0

  if noConfirmation then
      copyFlags = copyFlags + 16
  end if
  if newName then
      copyFlags = copyFlags + 8
  end if

  '------------------------------------------------------------------
  ' Copy the arg to destination
  '------------------------------------------------------------------

  oDestination.CopyHere arg, copyFlags

  '------------------------------------------------------------------
  ' Track what has been copied
  '------------------------------------------------------------------

  count = count + 1

  if count > 1 then msg = msg & vbCrLf & "-----" & vbCrLf

  msg = msg & arg & " copied to" & vbCrLf & oDestination.Items.Item.Path

next

'------------------------------------------------------------------
' Indicate what was copied
'------------------------------------------------------------------

choice = ws.Popup (msg, 15, "Auto OK in 15 seconds", 64)

wscript.Quit(0)