[vb6] vérifier qu'un fichier existe par son url

Commenter

Contenu du snippet

C'est une variante de l'API FileExists mais pour l'internet. Avec la fonction "urlFileExists" le contrôle on-line est possible !

Source / Exemple : 


Private Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000

Private Const INTERNET_DEFAULT_FTP_PORT = 21   'Port FTP par défaut.
Private Const INTERNET_DEFAULT_GOPHER_PORT = 70    'Port Gopher par défaut.
Private Const INTERNET_DEFAULT_HTTP_PORT = 80  'Port HTTP par défaut.
Private Const INTERNET_DEFAULT_HTTPS_PORT = 443 'Port HTTPS par défaut.
Private Const INTERNET_DEFAULT_SOCKS_PORT = 1080   'Port Socks (firewall) par défaut.

Private Const INTERNET_SERVICE_FTP = 1     'Service FTP.
Private Const INTERNET_SERVICE_GOPHER = 2  'Service Gopher.
Private Const INTERNET_SERVICE_HTTP = 3    'Service HTTP.

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szUrl As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
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 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 InternetOpenUrl Lib "wininet.dll" Alias _
    "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, _
    ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, _
    ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As _
    Long, ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, _
    lNumberOfBytesRead As Long) As Integer
    
Global rtGetHTTP As String

Public Function isConnected(sURL As String) As Boolean
    isConnceted = False
        If InternetCheckConnection("http://www.google.com", &H1, 0&) = 0 Then Exit Function
    isConnceted = True
End Function
    
Private Function urlGetStatus(ByVal sURL As String) As String
'Retourne deux parametres conca par un ;
'0 = Status
'1 = Status text
'Si ya besoin d'autre chose, faut changer ce code
urlGetStatus = "-1;Erreur fonction"

Dim myHTTP As WinHttpRequest
        
    Set myHTTP = New WinHttp.WinHttpRequest
        With myHTTP
            .Open "GET", sURL, True
            .Send
            .WaitForResponse 15
            Do Until .WaitForResponse = True
                DoEvents
            Loop
            'retour local
            urlGetStatus = .Status & ";" & .StatusText
            'retour global
            rtGetHTTP = .Status & ";" & .StatusText
        End With
    Set myHTTP = Nothing
    
End Function

Public Function urlFileExists(sURL As String) As Boolean
Dim rtGET As String, rtURL() As String
Dim hOpen As Long, hUrl As Long
Dim bufData As String, bytRead As Long

    bufData = Space(4096)
    hOpen = InternetOpen("IE", &H1, vbNullString, vbNullString, &H0)
        hUrl = InternetOpenUrl(hOpen, sURL, vbNullString, &H0, INTERNET_FLAG_EXISTING_CONNECT, &H0)
        
        'On split le retour dans un tableau
        rtGET = urlGetStatus(sURL)
        rtURL = Split(rtGET, ";")
            
            'Fichier trouvé ou autres
            If rtURL(0) = "200" Then
                urlFileExists = True
            Else
                urlFileExists = False
            End If
                
    InternetCloseHandle hOpen
    bufData = ""
    ReDim rtURL(0)
End Function

Function urlGetFiles(ByVal url As String, ByVal FileName As String) As Boolean
urlGetFiles = False
Dim value As Long

    If Dir$(FileName) <> "" Then
        Kill FileName
    End If
    
    Screen.MousePointer = 11
        value = URLDownloadToFile(0, url, FileName, 0, 0)
        DoEvents
    Screen.MousePointer = 1
        
urlGetFiles = True
End Function

Conclusion :


Exemple dans un bouton:

Private Sub Command1_Click()
Dim bReady As Boolean
Dim bDown As Boolean

Dim sTestURL As String
Dim sDestFileName As String, sDestFilePath As String, sDestPath As String

'INIT AR
sTestURL = "http://www.google.fr/intl/fr_fr/images/logo.gif"
sDestFilePath = "C:\Users\Public\Desktop\"
sDestFileName = Mid$(sTestURL, InStrRev(sTestURL, "/") + 1)
sDestPath = sDestFilePath & sDestFileName

bReady = urlFileExists(sTestURL)
If bReady = False Then
MsgBox "Fichier introuvable !", vbExclamation, "RT: " & modHTTP.rtGetHTTP
Else
MsgBox "Fichier trouvé !", vbInformation, "RT: " & modHTTP.rtGetHTTP
If MsgBox("Telechargez maintenant ?", vbQuestion + vbYesNo) = vbYes Then
bDown = modHTTP.urlGetFiles(sTestURL, sDestPath)
If bDown = True Then
MsgBox "Fichier telechargé avec succes:" & vbCrLf & sDestPath, vbInformation
Else
MsgBox "Erreur lors du telechargement !", vbExclamation
End If
End If
End If
End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (Duke49)