1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
| Dim FTPServer,Login,Password,NomDossier,CheminDossier
Copyright = "FolderFTPUpload © Hackoo © 2012"
'**********-Trois Paramètres à modifier-*************
FTPServer = "VotreServeurFTP"
Login = "VotreLogin"
Password= "VotrePassword"
'****************************************************
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
FTPUpload = 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
FTPUpload = "Error: File Not Found"
MsgBox "Erreur : Fichier Non Trouvé ?",16,"Erreur : Fichier Non Trouvé ? "&Copyright
ElseIf InStr(sResults, "Login authentication failed") > 0 Then
FTPUpload = "Error: Login Failed."
MsgBox "Login authentication a echoué !",16,"Login authentication failed ! "&Copyright
Else
FTPUpload = "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 partique qui sert à ajouter "les doubles quotes dans une variable"
Function qq(strIn)
qq = Chr(34) & strIn & Chr(34)
End Function |
