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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
| Option Compare Database
Option Explicit
'-------------------
'Déclaration des API
'-------------------
Private 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
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private 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
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFile As Long, ByVal localFile As String, ByVal newRemoteFile As String, ByVal dwFlags As Long, ByVal lContext As Long) As Boolean
' Renvoie 1(TRUE) ou 0(FALSE)
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" _
(ByVal hFtpSession As Long, ByVal lpszBuffer As String, _
ByRef lpdwBufferLength As Long) As Long
' Renvoie un handle(<>0) ou NULL(0)
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" _
(ByVal hConnect As Long, ByVal lpszSearchFile As String, _
ByRef lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
' utilisé après FtpFindFirstFile pour continuer énumération
' Renvoie 1(TRUE) ou 0(FALSE)
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" _
(ByVal hFind As Long, ByRef lpvFindData As WIN32_FIND_DATA) As Long
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const scUserAgent = "VB OpenUrl"
Private Const INTERNET_FLAG_RELOAD = &H8000000 '(&H8000000 mode passif, 0 mode actif)
Private Const INTERNET_bin_asc = &H2 '(&H1 ascii, &H2 binaire)
' ---------------------
' FINDFILE Structure
' ---------------------
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
' cFileName As String * MAX_PATH
' cFileName(MAX_PATH - 1) As Byte
' cAlternateFileName(14 - 1) As Byte
cFileName As String * 260
cAlternateFileName As String * 13
End Type
Public Sub Download(sUrl As String, SaveAs As String)
'Exemple :
' Call Download("http://www.url.com/fichier.zip", "C:\Fichier.zip")
Dim hOpen As Long
Dim hOpenUrl As Long
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
Dim sMsg As String
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
Open SaveAs For Binary Access Write As #1
Put #1, , sBuffer
Close #1
If bRet Then
sMsg = sUrl & " a été transféré "
Else
sMsg = sUrl & " n'a pas pu être transféré"
End If
If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
'annoncer le résultat de l'opération
If sMsg <> "" Then
MsgBox sMsg
Else
MsgBox "aucun fichier transféré"
End If
End Sub
' ---------------------------------------------------------------------------------
' MultiDownLoad_Ftp
' ---------------------------------------------------------------------------------
' Arguments Exemple
' ------------ --------------------------------- ---------------------------
' sServeurFtp : Serveur FTP monserveurftp.fr
' sUID / sPWD : Nom utilisateur / Mot de passe
' sDossierFTP : Dossier FTP /doss1/doss2
' sFichierFTP : Nom fichier FTP ab*.txt
' sDossierLoc : Dossier local C:\Temp
' ---------------------------------------------------------------------------------
' Les exemples de valeurs d'arguments correspondent à l'url
' ftp://monserveurftp.fr/doss1/doss2/ab*.txt
' ---------------------------------------------------------------------------------
Sub MultiDownLoad_Ftp(sServeurFtp As String, sUID As String, sPWD As String, _
sDossierFTP As String, sFichierFTP As String, _
sDossierLoc As String, _
Optional bSimuler As Boolean = False)
' Internet Handles for Internet Session, Internet Connection, Internet File
Dim hInternetSess As Long, hIConnect As Long, hIFile As Long
' Internet handle for FtpFindFirstFile, and Find File Structure
Dim hIFF As Long, ffF As WIN32_FIND_DATA
'
Dim Retval As Long, sFileName As String, p As Long
Dim sBuff As String, lgBuffLen As Long
Dim sUrl As String, sSaveAs As String
'Ouvre session internet
hInternetSess = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'Connexion au site ftp (ex: "ftp.mozilla.org")
hIConnect = InternetConnect(hInternetSess, sServeurFtp, 21, sUID, sPWD, 1, 0, 0)
' Définit le répertoire distant
If Len(sDossierFTP) > 0 Then Retval = FtpSetCurrentDirectory(hIConnect, sDossierFTP)
' Vérifie répertoire courant
If bSimuler Then
lgBuffLen = 512: sBuff = String(lgBuffLen, vbNullChar)
Retval = FtpGetCurrentDirectory(hIConnect, sBuff, lgBuffLen)
If Retval <> 0 Then
Debug.Print "Nouv. Dossier ftp en cours : " & Left(sBuff, lgBuffLen)
Else
Debug.Print "Echec de FtpGetCurrentDirectory"
End If
End If
' Boucler sur recherche fichier(s) distant(s)
hIFF = FtpFindFirstFile(hIConnect, sFichierFTP & vbNullChar, ffF, 0, 0)
If hIFF <> 0 Then
Do
p = InStr(1, ffF.cFileName, vbNullChar)
sFileName = Left(ffF.cFileName, p - 1)
If bSimuler Then
Debug.Print sFileName
Else
' Création de l'url à télécharger
sUrl = "ftp://" & sServeurFtp
If Left(sDossierFTP, 1) <> "/" Then sUrl = sUrl & "/"
sUrl = sUrl & sDossierFTP
If Right(sUrl, 1) <> "/" Then sUrl = sUrl & "/"
sUrl = sUrl & sFileName
' Création chemin complet fichier local
sSaveAs = sDossierLoc
If Right(sSaveAs, 1) <> "\" Then sSaveAs = sSaveAs & "\"
sSaveAs = sSaveAs & sFileName
' ** Télécharger **
Download sUrl, sSaveAs
End If
If InternetFindNextFile(hIFF, ffF) = False Then Exit Do
Loop
InternetCloseHandle (hIFF)
End If
InternetCloseHandle hIConnect 'Ferme la connexion
InternetCloseHandle hInternetSess 'Ferme internet
End Sub |
Import plusieurs fichiers txt depuis ftp
Répondre avec citation
Partager