VBS copy userfiles to network share

April 28, 2009 at 05:17:28
Specs: Windows Vista
Hi I was digging around to find solution
I need to copy users documents to some network share
The point is to copy only office files not mp3 avis etc and leave file structure
What I did grab code from there and here, found solution which works for one type of files
Bold are my implementations so guys could You tell me what am I doing wrong
Const MY_DOCUMENTS = &H5&

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_DOCUMENTS)
Set objFolderItem = objFolder.Self
Wscript.Echo "Faili tiks kopeti no: "& objFolderItem.Path

Set WSHShell = CreateObject("WScript.Shell")
Set WSHNetwork = CreateObject("WScript.Network")
UserString = WSHNetwork.UserName
WSHNetwork.RemoveNetworkDrive "X:" ,True ,True
WSHNetwork.MapNetworkDrive "X:", "\\server\USER$\" & UserString ,True

Dim fileCount
Const toDir   = "x:\"
 
fileCount = CopyXLS(CreateObject("Scripting.FilesystemObject"), objFolderItem.Path, toDir) 
On Error Resume Next
WScript.StdOut.WriteLine "Copied " & fileCount & " files."
WScript.Quit fileCount
 
'oFSO   (object) - FileSystemObject to use
'sStart (string) = Source directory
'sEnd   (string) - Destination directory
Function CopyXLS(oFSO, sStart, sEnd) 'As Integer
  Dim d, f, i, w, ext
  w = 0
<b>  Dim ten
  ten = Array("doc","xls","docx","xlsx","vsd","vsdx","ppt","pptx","txt")
</b>
  If Right(sEnd, 1) <> "\" Then _
    sEnd = sEnd & "\"
  
  If Not oFSO.FolderExists(sEnd) Then _
    oFSO.CreateFolder sEnd
  
  With oFSO.GetFolder(sStart)
    For Each f In .Files
	      ext = oFSO.GetExtensionName(f)
<b>Do While w>8</b>
		  
	If Len(ext) And InStr(1, ten(w), ext, 1) And _
			ShouldCopy(oFSO, sEnd & f.Name, f.DateLastModified) Then
			f.Copy sEnd
			i = i + 1

			End If
  <b>w = w+ 1
Loop</b>
			Next 'f
    
    For Each d In .SubFolders
      i = i + CopyXLS(oFSO, d, sEnd & d.Name & "\")
    Next 'd
  End With
  CopyXLS = i
End Function
 
'oFSO    (object) - FileSystemObject to use
'sFile   (string) - File (w/ path) to check
'dCutoff (date)   - Date to compare to file's date.
Function ShouldCopy(oFSO, sFile, dCutoff) 'As Boolean
  With oFSO
    If Not .FileExists(sFile) Then
      ShouldCopy = True
      Exit Function
    End If
    
    ShouldCopy = .GetFile(sFile).DateLastModified < dCutoff
  End With
End Function


See More: VBS copy userfiles to network share

Report •


#1
April 28, 2009 at 23:21:02
Well I did it myself I was wondering for 2 days whether 2 cycles for...each could be implemented in one another
What this code does- copies files from my documents to network share filtered by extensions, if folder doesnot exist script creates it, it takes me 1 day, code is from this and another 10 forums, so I am very proud of myself
Const MY_DOCUMENTS = &H5&

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_DOCUMENTS)
Set objFolderItem = objFolder.Self
Wscript.Echo "Files will be copied from: "& objFolderItem.Path

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("Wscript.Network")
UserString = objNetwork.UserName
If (objFSO.DriveExists("X:") = True) Then
    objNetwork.RemoveNetworkDrive "X:", True, True
End If 
PString = "\\db\USERS\" & UserString

If Not objFSO.FolderExists(PString) Then
  objFSO.CreateFolder(PString)
End If

objNetwork.MapNetworkDrive "X:", PString ,True

Dim fileCount
Const toDir   = "X:\"
 
fileCount = CopyXLS(CreateObject("Scripting.FilesystemObject"), objFolderItem.Path, toDir) 
On Error Resume Next
WScript.StdOut.WriteLine "Copied " & fileCount & " files."
WScript.Quit fileCount
 
'oFSO   (object) - FileSystemObject to use
'sStart (string) = Source directory
'sEnd   (string) - Destination directory
Function CopyXLS(oFSO, sStart, sEnd) 'As Integer
  Dim d, f, i, w, ext, ten, txe
  w = 0
  ten = Array("doc","xls","docx","xlsx","vsd","vsdx","ppt","pptx","txt")
    If Right(sEnd, 1) <> "\" Then _
    sEnd = sEnd & "\"
	If Not oFSO.FolderExists(sEnd) Then _
    oFSO.CreateFolder sEnd
	With oFSO.GetFolder(sStart)
	For Each f In .Files
      ext = oFSO.GetExtensionName(f)
			For Each txe in ten
			If Len(ext) And InStr(1, txe, ext, 1) And _
			ShouldCopy(oFSO, sEnd & f.Name, f.DateLastModified) Then
			f.Copy sEnd
			i = i + 1
			End If
			Next 'txe

	Next 'f
			
    For Each d In .SubFolders
      i = i + CopyXLS(oFSO, d, sEnd & d.Name & "\")
    Next 'd
  End With
  CopyXLS = i
End Function
 
'oFSO    (object) - FileSystemObject to use
'sFile   (string) - File (w/ path) to check
'dCutoff (date)   - Date to compare to file's date.
Function ShouldCopy(oFSO, sFile, dCutoff) 'As Boolean
  With oFSO
    If Not .FileExists(sFile) Then
      ShouldCopy = True
      Exit Function
    End If
    
    ShouldCopy = .GetFile(sFile).DateLastModified < dCutoff
  End With
End Function


Report •
Related Solutions


Ask Question