XL 2010 VBA - Uploader un dossier sur ftp

B

Bens7

XLDnaute Impliqué
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 ...
 
Trier par date Trier par votes
MJ13

MJ13

XLDnaute Barbatruc
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
 
Dernière édition:
Vote positif 0 Vote négatif
B

Bens7

XLDnaute Impliqué
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.
Cliquez pour agrandir...
Alors la par contre ... aucune idée comment faire
 
Vote positif 0 Vote négatif
MJ13

MJ13

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
B

Bens7

XLDnaute Impliqué
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.
Cliquez pour agrandir...

j'ai déjà 28 Feuil dans mon fichier ... tous simplement uploader tout ... sans list sans rien ... c'est plus porpre
 
Vote positif 0 Vote négatif
B

Bens7

XLDnaute Impliqué
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...
 
Dernière édition:
Vote positif 0 Vote négatif
MJ13

MJ13

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
B

Bens7

XLDnaute Impliqué
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 !
 
Vote positif 0 Vote négatif

Discussions similaires

cathodique
  • Résolu(e)
XL 2010 Utilisation API
2
Réponses
22
Affichages
867
patricktoulon
patricktoulon
Y
  • Résolu(e)
Affichage Userform en plein écran quelque soit la taille de l'écran
2
Réponses
22
Affichages
934
youguybass
Y
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
137
patricktoulon
patricktoulon
riton00
  • Résolu(e)
XL 2021 Modification d'un code VBA
Réponses
5
Affichages
349
kiki29
kiki29
patricktoulon
  • Question
XL 2013 enregistrer la capture d'une shape avec les api avec transparence
2
Réponses
26
Affichages
916
patricktoulon
patricktoulon
A
Ce que VBA sait faire d'amusant
Réponses
2
Affichages
438
AR MOR
A
patricktoulon
  • Résolu(e)
XL 2013 prise de tête avec une variable static
Réponses
3
Affichages
361
patricktoulon
patricktoulon
V
  • Question
XL 2021 Upload fichier depuis Bureau
Réponses
7
Affichages
498
vmax67
V
patricktoulon
  • Résolu(e)
Autres que penses vous de ce mini test benchmark(timer plus precis)
Réponses
6
Affichages
600
patricktoulon
patricktoulon
R1-
  • Question
XL 2016 Impossible de SendKeys une tabulation
Réponses
4
Affichages
584
R1-
R1-

Membres actuellement en ligne

5 membres et 83 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 096
Messages
2 116 183
Membres
112 677
dernier inscrit
Justine11