TÉLÉCHARGEMENT D'UN FICHIER V1.1

'Control      : OCX_Download
'Auteur       : Emmanuel Bouillon
'E-mail       : ebouillon@ifrance.com
'Page perso   : http://informatique.monhttp.com/
'Dernière MAJ : 06/03/2002
'Version Act  : 1.1
'
'V 1.1:
'   -- Support du resuming (ajout d'un argument a la fonction Download)
'   -- un bug corrigé
'
'A venir:
'  -- Une meilleur gestion de la vitesse
'  -- Le temps
'  -- Un controle d'erreur

'J'ai rajouté plusieurs boucles avec Inet.StillExecuting
'pour etre sur que le control n'est pas en train de faire qqc

'Génere une erreur si il y a une variable inconnue
Option Explicit

'Défini les evenements
Public Event Progress(Percent As Byte, Taille_Recue As Long, Taille_Totale As Long, Vitesse As Long)
Public Event ChangementStatus(State As String)

Const Chunk_Size = 1024
Const Retour = 4096

Dim Pourcent As Byte
Dim Taille_Recue As Long
Dim Taille_Totale As Long
Dim Vitesse As Long
Dim LastTailleRecue As Long
Dim File As Integer
Dim StrHeader
Dim Msg
Dim Data() As Byte

'Procedure de téléchargement
Public Sub Download(Source As String, Destination As String, Optional AutoResume As Boolean = True)
   'En cas d'erreur, aller a l'etiquette "ErreurDownload"
   'On Error GoTo ErreurDownload
   
   'Initialise les variables
   Pourcent = 0
   Taille_Recue = 0
   Taille_Totale = 0
   Vitesse = 0
   LastTailleRecue = 0
   File = 0
   StrHeader = ""
   
   'Envoi l'evenement "ChangementStatus" avec pour argument le Status
   RaiseEvent ChangementStatus("Initialisation...")
   Lbl_Status = "Initialisation..."
   RaiseEvent Progress(0, 0, 1, 0)

   'Attends qu'il ai terminé ses operations
   While Inet.StillExecuting
      DoEvents
   Wend

   'Initialise le controle Internet Transfert
   Inet.URL = Source
   Inet.Execute , "GET"
   
   'Attends qu'il ai terminé ses operations
   While Inet.StillExecuting
      DoEvents
   Wend
   
   Lbl_Source = "Source : " & Source
   Lbl_Destination = "Destination : " & Destination
   RaiseEvent ChangementStatus("Recherche de la taille du fichier...")
   Lbl_Status = "Recherche de la taille du fichier..."
   
   'Utilise la fonction Taille pour récuperer la taille du fichier
   Taille_Totale = Taille(Source)
   Bar.Max = Taille_Totale
   Taille_Recue = 0
   Bar.Value = Taille_Recue
   
   RaiseEvent ChangementStatus("Ouverture du fichier de destination...")
   Lbl_Status = "Ouverture du fichier de destination..."
   
   'Cherche un no de fichier libre
   File = FreeFile()
   
   'Ouverture du fichier de destination
   Open Destination For Binary Access Write As #File
   
   'Si le fichier de destination existe deja :
   If FileLen(Destination) > 4096 Then
      If AutoResume = False Then Msg = MsgBox("Le fichier de destination existe déja, voulez-vous continuer le transfert ?", vbYesNoCancel, "Le fichier de destination existe déja")
                                  'Si AutoResume est sur False, on demande si il faut reprendre le téléchargement
      If Msg = vbNo Then          'Si non, on ferme le fichier de destination,
         Close #File              'On le supprime et on le créé
         Kill Destination
         Open Destination For Binary Access Write As #File
      End If
      
      If Msg = vbCancel Then      'Si "cancel",
         GoTo Fin                 'on arrete le téléchargement
      End If
                                  'Si AutoResume est sur True
                                  'ou si on a chosit de continuer
                                  'le téléchargement...
      If AutoResume = True Or Msg = vbYes Then
         RaiseEvent ChangementStatus("Reprise du téléchargement...")
         Taille_Recue = FileLen(Destination)
         Seek #File, Taille_Recue + 1
         Inet.Execute , "GET", , "Range: bytes=" & CStr(Taille_Recue) & "-" & vbCrLf
      End If
   End If
   
   'Attends qu'il ai terminé ses operations
   While Inet.StillExecuting
      DoEvents
   Wend
   
   'Debut du téléchargement
   RaiseEvent ChangementStatus("Téléchargement en cours...")
   Lbl_Status = "Téléchargement en cours..."
   Timer.Enabled = True              'Activation du Timer (pour la vitesse)
   Do
    DoEvents                         'Télécharge un bloc de données
    Data = Inet.GetChunk(Chunk_Size, icByteArray)
    Put #File, , Data                'Les enregistre dans le fichier
    Taille_Recue = Taille_Recue + UBound(Data, 1) + 1
    Bar.Value = Taille_Recue         'Met a jour la bar de progression
    Lbl_State = Taille_Recue & " / " & Taille_Totale & " - " & Pourcent & " %"
    Pourcent = Round(Taille_Recue / Taille_Totale * 100)
                        'Calcule la progression
    RaiseEvent Progress(Pourcent, Taille_Recue, Taille_Totale, Vitesse)

Loop While UBound(Data, 1) > 0
'Ferme le fichier
Close #File

Timer.Enabled = False
RaiseEvent ChangementStatus("Téléchargement terminé")
Lbl_Status = "Téléchargement terminé"
Exit Sub

'En cas d'erreur
ErreurDownload:
On Error Resume Next
If MsgBox("Erreur " & Err.Number & " - " & Err.Description & vbCrLf & "Effacer le fichier ?", vbYesNo, "Le téléchargement a échoué") = vbYes Then Kill Destination
Fin:
RaiseEvent ChangementStatus("Une erreur c'est produite !")
Lbl_Status = "Une erreur c'est produite !"
Close #File
End Sub

'Defini la vitesse
Private Sub Timer_Timer()
   Vitesse = (Taille_Recue - LastTailleRecue) * 2
   LastTailleRecue = Taille_Recue
End Sub

'Retrouve la taille d'un fichier sur internet
'Cette fonction peut être appelée sans necessiter
'un téléchargement, car elle utilise un control Inet
'différent
Public Function Taille(URL As String) As Long

Inet_Taille.URL = URL
Inet_Taille.Execute , "GET"

'Fait patienter le control Inet jusqu'a ce qu'il
'ait terminé ses taches
While Inet_Taille.StillExecuting
   DoEvents
Wend

'Cherche la taille
StrHeader = Inet_Taille.GetHeader("Content-Length")
Taille = Val(StrHeader)

End Function

'Arrete les operations des controls Inet en cours
Public Sub Cancel()
On Error Resume Next
Inet.Cancel
Inet_Taille.Cancel
RaiseEvent ChangementStatus("Téléchargement interrompu")
Lbl_Status = "Téléchargement interrompu"
Timer.Enabled = False
End Sub
  

Télécharger le zip