[XL-2007] Transfert csv vers ftp en vba Excel

Code:

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
Public Function GoOn()
    'Path and Name of file to FTP
    Dim strPath
    Dim strFileName
    Dim ftpServer
    Dim strUserName
    Dim strPassword
    Dim RepSever
    Dim ExpWin
    GoOn = False
    Set ExpWin = New clsWindowsExporer
    strPath = "c:\DezipFtp\"
    ExpWin.Creer_Repertoires strPath
    strFileName = strPath & "test.csv"
 
'    FTP Server Settings
    ftpServer = "Test.fr"
    strUserName = "Testr"
    strPassword = "123456789"
    RepSever = "/ftp-Test/MyRep/Test"
 
'    Exécution des commandes FTP :/TestFtpRd
   GoOn = FTP_Data(strPath, strFileName, ftpServer, strUserName, strPassword, RepSever)
 
   ExpWin.Supprimer_Fichier strPath & "StartFtpOk.txt"
End Function
 
'Permet de temporiser le traitement pour attendre la fin de l'exécution  d'une tache :
Sub Tempo(T, F)
    Dim d
    Dim a
    d = Now
    a = 0
    While DateDiff(F, d, Now) < T
        a = a + 1
    Wend
End Sub
Function FTP_Data(strPath, strFileName, ftpServer, strUserName, strPassword, RepSever)
 
Dim pFile
Dim ExpWin
Set ExpWin = New clsWindowsExporer
 
 FTP_Data = False
 
'Création de la commande d'exécution de récupération du fichier (eclenchement.txt)
ExpWin.Supprimer_Fichier strPath & "FTP_cmd_Get.txt"
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", "user" & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", strUserName & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", strPassword & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", "CD " & RepSever & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", "Get " & strFileName & " " & strPath & strFileName & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", "Close" & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Get.txt", "quit" & vbCrLf
 
'Création du fichier Bat de réception FTP
ExpWin.Supprimer_Fichier strPath & "FTP_Run_Get.bat"
ExpWin.FichierLog strPath & "FTP_Run_Get.bat", "ftp -n -s:" & Chr(34) & strPath & "FTP_cmd_Get.txt" & Chr(34) & Space(1) & ftpServer & vbCrLf
ExpWin.FichierLog strPath & "FTP_Run_Get.bat", "Del " & strPath & "Go.txt" & vbCrLf
 
'Execute FTP command
Dim Shell
Set Shell = WScript.CreateObject("WScript.Shell")
Shell.Run (strPath & "FTP_Run_Get.bat")
 
TesteFichier strPath & "FTP_cmd.txt", False
'Création de la commande d'exécution de d'envoi des fichiers vers le serveur FTM (eclenchement.txt, dump_ibis.mdb)
ExpWin.Supprimer_Fichier strPath & "FTP_cmd_Put.txt"
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", "user" & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", strUserName & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", strPassword & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", "CD " & RepSever & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", "Put " & Chr(34) & strFileName & Chr(34) & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", "Close" & vbCrLf
ExpWin.FichierLog strPath & "FTP_cmd_Put.txt", "quit" & vbCrLf
 
'Création du fichier Bat de réception FTP
ExpWin.Supprimer_Fichier strPath & "FTP_Run_Get.bat"
ExpWin.FichierLog strPath & "FTP_Run_Get.Put", "ftp -n -s:" & Chr(34) & strPath & "FTP_cmd_Put.txt" & Chr(34) & Space(1) & ftpServer & vbCrLf
 
'Execute FTP command
Set Shell = WScript.CreateObject("WScript.Shell")
Shell.Run (strPath & "FTP_Run_Put.bat")
Set Shell = Nothing
End Function

Code:

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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe(Repertoires)
Dim Fso 'As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = Fso.FolderExists(Repertoires)
Set Fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
 
Dim Fso ' As Object
Dim Rep ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = Fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim T
Dim R ' As String
Dim I ' As Long
R = ""
T = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(T)
    If Trim("" & T(I)) <> "" Then
        R = R & Trim("" & T(I)) & "\"
        If Repertoires_Existe(R) = False Then Fso.CreateFolder R
    End If
Next
Set Fso = Nothing
End Sub
 
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source, Destination)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFolder Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Sub Deplace_Repertoire(Source, Destination)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFolder Source, Destination
Set Fso = Nothing
End Sub
 
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFolder DelRepertoire, True
Set Fso = Nothing
End Sub
'Taille d'un répertoire
Public Function Taille_Fichier(Fichier)
Dim Fso ' As Object
Dim Fich ' As Object
If Fichier_Exist("" & Fichier) = False Then Taille_Fichier = 0: Exit Function
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fich = Fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = Fso.FileExists(Fichier)
Set Fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier)
Dim Fso ' As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = Fso.GetBaseName(Fichier)
Set Fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier)
Dim Fso ' As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = Fso.GetExtensionName(Fichier)
Set Fso = Nothing
End If
End Function
 
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source, Destination)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source, Destination)
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFile Source, Destination
Set Fso = Nothing
End Sub
 
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier)
If Fichier_Exist(DelFichier) = True Then
Dim Fso ' As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFile DelFichier, True
Set Fso = Nothing
End If
End Sub
Function AppendTxt(sFile, sText)
Dim Fso, NewFichier
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(sFile, 8)
 
NewFichier.Write sText
NewFichier.Close
 
Set NewFichier = Nothing
Set Fso = Nothing
 
End Function
 
Public Sub FichierLog(sFile, TXT)
Dim Fso
'CreerPath FichierLog
 
Set Fso = CreateObject("Scripting.FileSystemObject")
 
If Fso.FileExists(sFile) = False Then EnteteFichier sFile
 
AppendTxt sFile, TXT
End Sub
 
Sub EnteteFichier(Fichier)
Dim TXT, Fso, NewFichier
TXT = ""
 'WScript.Echo Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write TXT
NewFichier.Close
 
 
Set NewFichier = Nothing
Set Fso = Nothing
End Sub