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 |
Partager