[VBS] FOLDER2FTPUPLOAD

Dim FTPServer,Login,Password,NomDossier,CheminDossier
Copyright = "FolderFTPUpload © Hackoo © 2012"

'**********-Trois Paramètres à modifier-*************
FTPServer = "ftp.server.com"
Login = "MyLogin"
Password= "MyPassword"
'****************************************************

Call Parcourir_Dossier()

sub Parcourir_Dossier()
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "Veuillez choisir un dossier pour uploader son contenu"&vbcr&vbTab&Copyright, 1, "c:\Programs")
If objFolder Is Nothing Then
    Wscript.Quit
End If
NomDossier = objFolder.title
CheminDossier = objFolder.self.path
Question = MsgBox("Vous avez Choisi le Dossier " &qq(NomDossier)& " qui se localise dans ce chemin :" &Vbcr& qq(CheminDossier)&vbcr&VbTab&VbTab&VbTab&" Continuez ?",vbYesNo + vbQuestion,"Le Dossier Choisi est "&qq(NomDossier)&" "&Copyright)
If Question = VbYes Then
FolderFTPUpload FTPServer,Login,Password,CheminDossier,NomDossier
else
wscript.Quit
End If
end sub

Function FolderFTPUpload(sSite, sUsername, sPassword, sLocalFolder, sRemotePath) 
  Const OpenAsDefault = -2
  Const FailIfNotExist = 0
  Const ForReading = 1
  Const ForWriting = 2
 
  Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
  Set oFTPScriptShell = CreateObject("WScript.Shell")
  Set ws = CreateObject("wscript.Shell")
  sRemotePath = Trim(sRemotePath)
  sLocalFolder = Trim(sLocalFolder)
  
  'Vérifier si le chemin, contient des espaces. 
  'si Oui,alors nous avons besoin d'ajouter des guillemets pour s'assurer qu'il passe correctement.
 
  If InStr(sRemotePath, " ") > 0 Then
    If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
      sRemotePath =  """"&sRemotePath&""""
    End If
  End If
 
  If InStr(sLocalFolder, " ") > 0 Then
    If Left(sLocalFolder, 1) <> """" And Right(sLocalFolder, 1) <> """" Then
      sLocalFolder = """"&sLocalFolder&""""
    End If
  End If
  
 sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
  Call ContenuDossier(CheminDossier)

  Set f = oFTPScriptFSO.OpenTextFile(sFTPTemp &"\ContenuDossier.txt", ForReading, OpenAsDefault)
  LireTout = f.ReadAll
  Fichier = split(LireTout,VbcrLF)
  f.Close
  'construire un fichier de configuration pour passer les commandes ftp
  sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
  sFTPScript = sFTPScript & sPassword & vbCRLF
  sFTPScript = sFTPScript & "mkdir " & sRemotePath & vbCRLF
  sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
  sFTPScript = sFTPScript & "binary" & vbCRLF
  sFTPScript = sFTPScript & "prompt n" & vbCRLF
  For i=LBound(Fichier) to UBound(Fichier)-1
  sFTPScript = sFTPScript & "put "& Fichier(i) & vbCRLF
  Next
  sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
 
  sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
  sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
  
 'Ecrire les commandes ftp à passer dans un fichier temporaire.
  Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
  fFTPScript.WriteLine(sFTPScript)
  fFTPScript.Close
  Set fFTPScript = Nothing
 
  oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
  " > " & sFTPResults,0, TRUE
 
  'Vérifier le résultat du Transfert de l'upload
  Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
  FailIfNotExist, OpenAsDefault)
  sResults = fFTPResults.ReadAll
  fFTPResults.Close
 
  oFTPScriptFSO.DeleteFile(sFTPTempFile)
  'oFTPScriptFSO.DeleteFile (sFTPResults)
 
  If InStr(sResults, "226") > 0 Then
    FolderFTPUpload = True
    MsgBox "Tout les fichiers contenu dans le Dossier : " &sLocalFolder& vbcr & vbcr & " ont été uploadés avec succés !"&vbcr&  LireTout,64,"Résultat du Transfert d'Upload "&Copyright

  ElseIf InStr(sResults, "File not found") > 0 Then
    FolderFTPUpload = "Error: File Not Found"
    MsgBox "Erreur : Fichier Non Trouvé ?",16,"Erreur : Fichier Non Trouvé ? "&Copyright
  ElseIf InStr(sResults, "Login authentication failed") > 0 Then
    FolderFTPUpload = "Error: Login Failed."
    MsgBox "Login authentication a echoué !",16,"Login authentication failed ! "&Copyright
  Else
    FolderFTPUpload = "Error: Unknown."
    MsgBox "Erreur: Inconnu ?",16,"Erreur: Inconnu ? "&Copyright
  End If
 
  Set oFTPScriptFSO = Nothing
  Set oFTPScriptShell = Nothing
End Function

sub ContenuDossier(sLocalFolder)
Set ws = CreateObject("wscript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
sFTPTemp = ws.ExpandEnvironmentStrings("%TEMP%")
if fso.FileExists(sFTPTemp &"\ContenuDossier.txt") Then
  fso.DeleteFile sFTPTemp &"\ContenuDossier.txt"
End if 
Command ="cmd /c for %I in ("&sLocalFolder&"\*.*) do (echo ""%I"") >> "& sFTPTemp &"\ContenuDossier.txt"""
Resultat = ws.run(command,0,True)
End sub

'c'est une fonction très pratique qui sert à ajouter "les doubles quotes dans une variable" 
Function qq(strIn) 
    qq = Chr(34) & strIn & Chr(34)
End Function