XL 2010 VBA - Uploader un dossier sur ftp

Bens7 · 17 Mai 2018

Bonjour a tous !
Bon voila je sais pas si ça se fait mais je relance un sujet de 2013 ... je ne pensse pas qu'il est suivis :

https://www.excel-downloads.com/threads/vba-copie-un-fichier-vers-un-dossier-ftp.217730/

- J'ai réussi a uploader un fichier grâce au code de motard59 qui fonctionne parfaitement :

VB:

Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUsername As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer


Sub ftp()
'transfère des fichiers du disque local vers un serveur ftp (upload, mode passif)
Dim Start As Single

'PARAMETRES************************
fichier = "C:\Users\BEN\Desktop\TEMP\1.jpg"
login = "xxxxxxxxxxxxxxx"
mot_passe = "xxxxxxxxxxxxxxxxx"
rép = "/web/FTP/TEMP"
bin_asc = &H2 '(&H1 ascii, &H2 binaire)
Mode = &H8000000 '(&H8000000 mode passif, 0 mode actif)
'**********************************

'lancer le transfert
internet_ok = InternetOpen("PutFtpFile", 1, "", "", 0)
If internet_ok = 0 Then
MsgBox "connection internet impossible"
Exit Sub
End If
ftp_ok = InternetConnect(internet_ok, "ftp.xxxxxxxxxxxxx.com", 21, login, mot_passe, 1, Mode, 0)
If ftp_ok = 0 Then
MsgBox "connection impossible"
Exit Sub
End If
sélect_rép = FtpSetCurrentDirectory(ftp_ok, rép)
If sélect_rép = 0 Then
MsgBox "impossible de trouver le répertoire "
Exit Sub
End If

'nom du fichier sans le chemin
nomfich = fichier
Do While InStr(nomfich, "\") > 0
nomfich = Right(nomfich, Len(nomfich) - InStr(nomfich, "\"))
Loop

'transférer le fichier
succès = FtpPutFile(ftp_ok, fichier, nomfich, bin_asc, 0)
If succès Then
résult = nomfich & " a été transféré "
Else
résult = nomfich & " n'a pas pu être transféré"
End If

'fermer les pointeurs, ménage
InternetCloseHandle ftp_ok
InternetCloseHandle internet_ok

'annoncer le résultat de l'opération
If résult <> "" Then
UserForm3.Label1 = résult
UserForm3.Show
'MsgBox résult
Else
UserForm3.Label1 = "aucun fichier transféré"
UserForm3.Show

'MsgBox "aucun fichier transféré"
End If

End Sub

Impossible par contre d'uploader tout le contenu d'un dossier ( ou tous un dossier complet )
j'ai essayer ceci :

VB:

'PARAMETRES************************
fichier = "C:\Users\BEN\Desktop\TEMP"

afin d'uploader tout le dossier TEMP mais sans succes ! si quelqun veux bien m'aider a adapter ce même code.. j'ai galérer a le faire fonctionne et j'y tiens maintenant en plus pas besoin de référence supplémentaire ...

Bens7 · 28 Mai 2018

petit up ??

MJ13 · 29 Mai 2018

Bonjour Bens7

Il suffit de trouver tous les fichiers qui t'intéresse avec cette macro en mettant sur une feuille en A1 le nom du dossier à lister.

Puis de sélectionner l'ensemble des cellules contenant le nom des fichiers à traiter puis boucler avec un for each cell in selection: Ta procédure de transfert avec le nom du fichier en variable: next.

Code:

Sub Dir_Etoile()
Cells(1, 1).Select
    N = 2
     DOSSIER = Cells(1, 1).Value
    NF = Dir(DOSSIER & "\*.*")
    Do While NF <> ""
        N = N + 1
        Cells(N, 1) = ActiveCell & "\" & NF
        NF = Dir    ' suivant
    Loop
ActiveCell.Offset(0, 1) = N - 2
End Sub

Bens7 · 30 Mai 2018

Merci tout d'abord pour la reponsse !
Alors étant novice j'ai réussi a faire tourner ta macro pour lister les fichier ...

MJ13 à dit:
Puis de sélectionner l'ensemble des cellules contenant le nom des fichiers à traiter puis boucler avec un for each cell in selection: Ta procédure de transfert avec le nom du fichier en variable: next.

Alors la par contre ... aucune idée comment faire

MJ13 · 30 Mai 2018

Bonjour Bens7

Pour la partie "for each", tu peux tester ce code, en sélectionnant les cellules contenant les noms de fichier avec le chemin. Il faudra aussi modifier le code Ftp avec FichierUp et rajouter un Public FichierUp en tête de module standard.

VB:

Public FichierUp

'A modifier dans la macro ftp
'PARAMETRES************************
'fichier = "C:\Users\BEN\Desktop\TEMP\1.jpg"
fichier = FichierUp

Sub Transfert_Fichiers_Sel()
For Each cell In Selection
cell.Select
FichierUp = cell.Value
ftp
Next
End Sub

Bens7 · 4 Juin 2018

Merci mais pas moyen avec ce petit For Each (tous les fichiers du dossier) + fichier = FichierUp
sans passer par

MJ13 à dit:
sur une feuille en A1 le nom du dossier à lister.

Puis de sélectionner l'ensemble des cellules contenant le nom des fichiers à traiter puis boucler avec un for each cell in selection: Ta procédure de transfert avec le nom du fichier en variable: next.

j'ai déjà 28 Feuil dans mon fichier ... tous simplement uploader tout ... sans list sans rien ... c'est plus porpre

MJ13 · 4 Juin 2018

Re Bens7

Je n'ai pas bien compris si la méthode que je t'avais donné dans le post #5 avait fonctionné.

Si c'est OK, on pourra envisager la suite.

Bens7 · 5 Juin 2018

Bon ca fonctionne voici le code actuel :

VB:

Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUsername As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lcontext As Long) As Long
Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

'a ajouter pour le dossier complet
Public FichierUp

Sub listdossier()
Cells(1, 1).Select
    N = 2
     DOSSIER = Cells(1, 1).Value
    NF = Dir(DOSSIER & "\*.*")
    Do While NF <> ""
        N = N + 1
        Cells(N, 1) = ActiveCell & "\" & NF
        NF = Dir    ' suivant
    Loop
ActiveCell.Offset(0, 1) = N - 2
transfertmultiple
End Sub

Sub transfertmultiple()
For Each cell In Selection
cell.Select
FichierUp = cell.Value
subuploadftpdossier
Next
MsgBox ("DOSSIER TRANSFERE")
End Sub
Sub subuploadftpdossier()
'transfère des fichiers du disque local vers un serveur ftp (upload, mode passif)
Dim Start As Single

'PARAMETRES************************
fichier = FichierUp
login = "xxxxxxxxxxxx"
mot_passe = "xxxxxxxxxxxxx"
rép = "/web/FTP"
bin_asc = &H2 '(&H1 ascii, &H2 binaire)
Mode = &H8000000 '(&H8000000 mode passif, 0 mode actif)
'**********************************

'lancer le transfert
Internet_OK = InternetOpen("PutFtpFile", 1, "", "", 0)
If Internet_OK = 0 Then
MsgBox "connection internet impossible"
Exit Sub
End If
FTP_OK = InternetConnect(Internet_OK, "ltez.ftp.infomaniak.com", 21, login, mot_passe, 1, Mode, 0)
If FTP_OK = 0 Then
MsgBox "connection impossible"
Exit Sub
End If
sélect_rép = FtpSetCurrentDirectory(FTP_OK, rép)
If sélect_rép = 0 Then
MsgBox "impossible de trouver le répertoire FTP "
Exit Sub
End If

'nom du fichier sans le chemin
nomfich = fichier
Do While InStr(nomfich, "\") > 0
nomfich = Right(nomfich, Len(nomfich) - InStr(nomfich, "\"))
Loop

'transférer le fichier
succès = FtpPutFile(FTP_OK, fichier, nomfich, bin_asc, 0)
If succès Then
'résult = nomfich & " a été transféré "
Else
résult = nomfich & " n'a pas pu être transféré"
End If

'fermer les pointeurs, ménage
InternetCloseHandle FTP_OK
InternetCloseHandle Internet_OK

'annoncer le résultat de l'opération
If résult <> "" Then
MsgBox résult
Else
'MsgBox "aucun fichier transféré"
End If

End Sub

Mais comme dit la procédure reste assez contraignante pour l’utilisateur final... de visualiser la liste + sélectionner... si possible d'epurer juste un bouton ... la souris tourne ...MsgBox ("DOSSIER TRANSFERE") En fait uploader un dossier complet pas tout les fichiers contenue dans un dossier ... je penssais que en modifiant un peu le code d'upload on pouvais...

MJ13 · 5 Juin 2018

Re Ben7s

Merci pour le retour du code, cela fait toujours plaisir que le travail fonctionne dans les 2 sens.

Bon, si j'ai bien compris, tu peux tester l'adaptation de ton code:

VB:

Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUsername As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lcontext As Long) As Long
Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

'a ajouter pour le dossier complet
Public FichierUp

Sub Dossier_Transfert_UP()
'Cells(1, 1).Select
    'N = 2
    'Entrer le nom du dossier ici
     Dossier = "C:\Temp" 'Cells(1, 1).Value
    NF = Dir(Dossier & "\*.*")
    Do While NF <> ""
        N = N + 1
        'Cells(N, 1) = ActiveCell & "\" & NF
        FichierUp = Dossier & "\" & NF
        subuploadftpdossier
        NF = Dir    ' suivant
    Loop
'ActiveCell.Offset(0, 1) = N - 2
'transfertmultiple
MsgBox ("DOSSIER TRANSFERE")
End Sub

'Sub transfertmultiple()
'For Each cell In Selection
'cell.Select
'FichierUp = cell.Value
'subuploadftpdossier
'Next
'MsgBox ("DOSSIER TRANSFERE")
'End Sub
Private Sub subuploadftpdossier()
'transfère des fichiers du disque local vers un serveur ftp (upload, mode passif)
Dim Start As Single

'PARAMETRES************************
fichier = FichierUp
login = "xxxxxxxxxxxx"
mot_passe = "xxxxxxxxxxxxx"
rép = "/web/FTP"
bin_asc = &H2 '(&H1 ascii, &H2 binaire)
Mode = &H8000000 '(&H8000000 mode passif, 0 mode actif)
'**********************************

'lancer le transfert
Internet_OK = InternetOpen("PutFtpFile", 1, "", "", 0)
If Internet_OK = 0 Then
MsgBox "connection internet impossible"
Exit Sub
End If
FTP_OK = InternetConnect(Internet_OK, "ltez.ftp.infomaniak.com", 21, login, mot_passe, 1, Mode, 0)
If FTP_OK = 0 Then
MsgBox "connection impossible"
Exit Sub
End If
sélect_rép = FtpSetCurrentDirectory(FTP_OK, rép)
If sélect_rép = 0 Then
MsgBox "impossible de trouver le répertoire FTP "
Exit Sub
End If

'nom du fichier sans le chemin
nomfich = fichier
Do While InStr(nomfich, "\") > 0
nomfich = Right(nomfich, Len(nomfich) - InStr(nomfich, "\"))
Loop

'transférer le fichier
succès = FtpPutFile(FTP_OK, fichier, nomfich, bin_asc, 0)
If succès Then
'résult = nomfich & " a été transféré "
Else
résult = nomfich & " n'a pas pu être transféré"
End If

'fermer les pointeurs, ménage
InternetCloseHandle FTP_OK
InternetCloseHandle Internet_OK

'annoncer le résultat de l'opération
If résult <> "" Then
MsgBox résult
Else
'MsgBox "aucun fichier transféré"
End If
End Sub

Bens7 · 26 Juin 2018

Desole de pas etre revenu ! mais je veux dire BRAVO mj13 !!!!
voici le code actuel :

VB:

Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUsername As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lcontext As Long) As Long
Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

'a ajouter pour le Chemin complet
Public Dossierup

Sub uploadftpdossier()
    'Entrer le nom du Chemin ici
     Chemin = "C:\LOG" 'Nom du Chemin
    NF = Dir(Chemin & "\*.*")
    Do While NF <> ""
        N = N + 1
        'Cells(N, 1) = ActiveCell & "\" & NF
        Dossierup = Chemin & "\" & NF
       
        'Lance l'upload
        Transfertdossftp
        NF = Dir    ' suivant
    Loop

MsgBox (Chemin & " TRANSFERE SUR")
End Sub


Sub Transfertdossftp()
'transfère des fichiers du disque local vers un serveur ftp (upload, mode passif)
Dim Start As Single

'PARAMETRES************************
fichier = Dossierup
login = "xxxxxxxxxx"
mot_passe = "xxxxxxxxxxxxx"
rép = "/web/XLSM"
bin_asc = &H2 '(&H1 ascii, &H2 binaire)
Mode = &H8000000 '(&H8000000 mode passif, 0 mode actif)
'**********************************

'lancer le transfert
Internet_OK = InternetOpen("PutFtpFile", 1, "", "", 0)
If Internet_OK = 0 Then
MsgBox "connection internet impossible"
Exit Sub
End If
FTP_OK = InternetConnect(Internet_OK, "ltez.ftp.infomaniak.com", 21, login, mot_passe, 1, Mode, 0)
If FTP_OK = 0 Then
MsgBox "connection impossible"
Exit Sub
End If
sélect_rép = FtpSetCurrentDirectory(FTP_OK, rép)
If sélect_rép = 0 Then
MsgBox "impossible de trouver le répertoire FTP "
Exit Sub
End If

'nom du fichier sans le chemin
nomfich = fichier
Do While InStr(nomfich, "\") > 0
nomfich = Right(nomfich, Len(nomfich) - InStr(nomfich, "\"))
Loop

'transférer le fichier
succès = FtpPutFile(FTP_OK, fichier, nomfich, bin_asc, 0)
If succès Then
'résult = nomfich & " a été transféré "
Else
résult = nomfich & " n'a pas pu être transféré"
End If

'fermer les pointeurs, ménage
InternetCloseHandle FTP_OK
InternetCloseHandle Internet_OK

'annoncer le résultat de l'opération
If résult <> "" Then
MsgBox résult
Else
'MsgBox "aucun fichier transféré"
End If
End Sub

Encore 1000 merci !

XL 2010 VBA - Uploader un dossier sur ftp

Bens7

XLDnaute Impliqué

Bens7

XLDnaute Impliqué

MJ13

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

MJ13

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

MJ13

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

MJ13

XLDnaute Barbatruc

Bens7

XLDnaute Impliqué

Discussions similaires