Salut!
Je commence en VB6 et j'ai des problèmes avec mon fournisseur internet.  Je perds accès au net régulièrement et je veux le leur prouver.  Je veux créer une application qui fait constamment des ping à plusieurs sites différents pour découvrir quand je perds l'accès au net et quand je le retrouve et logger le tout dans un fichier.

J'utilise un bouton "start" pour déclancher l'application et un autre "stop" pour l'arrèter.  Je dois utiliser un thread pour faire un ping à 3 sites différents à chaque minute sans perdre le contrôle.

Voici le problème!

Tout d'abord, le code suivant se trouve dans un module "modPing.bas".  
---------------------------------------------------------------
Option Explicit
Private Const SOCKET_ERROR = 0
Private Const MAX_IP = 10

'**********************************
'Déclaration des types de données *
'**********************************
Private Type WSAdata
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 128) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Private Type Hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Type IP_OPTION_INFORMATION
    TTL As Byte
    Tos As Byte
    Flags As Byte
    OptionsSize As Long
    OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
    Address(0 To 3) As Byte
    Status As Long
    RoundTripTime As Long
    DataSize As Integer
    Reserved As Integer
    data As Long
    Options As IP_OPTION_INFORMATION
End Type

'***************************
'Déclaration des fonctions *
'***************************
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Boolean

'*****************************************
'Fait un ping au site passé en paramêtre *
'*****************************************
Public Function Ping(sAddr As String, Optional Timeout As Integer = 2000) As Integer
    Dim hFile As Long, lpWSAdata As WSAdata
    Dim hHostent As Hostent, AddrList As Long
    Dim Address As Long, rIP As String
    Dim OptInfo As IP_OPTION_INFORMATION
    Dim EchoReply As IP_ECHO_REPLY
    
    Call WSAStartup(&H101, lpWSAdata)
    
    If GetHostByName(sAddr + String(64 - Len(sAddr), 0)) <> SOCKET_ERROR Then
        CopyMemory hHostent.h_name, ByVal GetHostByName(sAddr + String(64 - Len(sAddr), 0)), Len(hHostent)
        CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
        CopyMemory Address, ByVal AddrList, 4
    End If
    
    hFile = IcmpCreateFile()
    
    If hFile = 0 Then
        Ping = -2 ' MsgBox "Unable to Create File Handle"
        Exit Function
    End If
    
    OptInfo.TTL = 255
    
    If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, Timeout) Then
        rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
    Else
        Ping = -1 ' MsgBox "Timeout"
    End If
    
    If EchoReply.Status = 0 Then
        Ping = EchoReply.RoundTripTime
    Else
        Ping = -3
    End If
    
    IcmpCloseHandle hFile
    WSACleanup

End Function

--------------------------------------------------------------------
Dans un projet seul (Ping.vbp), un bouton suffit pour appeler la fonction "ping" avec les instructions suivantes dans une "form" et ça fonctionne à merveille!!!

Private Sub Command1_Click()
    Dim Result As Integer
    
    Result = modPing.Ping("www.google.com")
    
    If Result < 0 Then
        MsgBox "Ping failed, error: " & Result
    Else
        MsgBox "Ping ok, Résultat: " & Result
    End If
End Sub

---------------------------------------------------------
Par contre, je veux appeler cette fonction à chaque minute dans un thread jusqu'à ce que je clique sur le bouton "stop" ou que je ferme l'application.  J'ai donc ajouté ce module à un autre projet (NetUpDown.vbp).

Voici la description de la "form" nommée "frmPrincipale" du nouveau projet.

1 textBox nommé "txtNetStatut"
1 textBox nommé "txtDateHre"
1 commandButton nommé "btnStart"
1 commandButton nommé "btnStop"
1 comboBox nommé "cmbLog"

Dans la form "frmPrincipale" j'ai le code suivant :

-------------------------------------------------------------------

'************************************************************
'  Règles à respecter pour ce programme!                    *
'************************************************************
' 1) Do not run the vb thread application from debug.       *
'    Run the application as a compiled executable.          *
'    Instead compile and run the executable.                *
'                                                           *
'    Call TerminateProcess(GetCurrentProcess, ByVal 0&)     *
'    will terminate the current vb process                  *
'                                                           *
' 2) Test each function first before embedding into the     *
'    thread frame work application.                         *
'                                                           *
' 3) Make sure the project is compiled as P-Code            *
'    (executable will fault if the binary is not P-Code)    *
'************************************************************
'*****************************************************
' Déclaration des variables globales
'*****************************************************
Public blnFichEcrit As Boolean

'*******************************************************
'Commandes exécutées lorsque le bouton Start est cliqué
'*******************************************************
Private Sub btnStart_Click()

    Dim lpThreadID As Long
    Dim strNomFich As String
    
    blnFichEcrit = False
    
    'Créer le Thread et l'événement pour ne créer qu'un seul thread
    lThreadHandle1 = CreateThread(ByVal 0&, ByVal 0&, AddressOf VerifNet, ByVal 0&, 0, lpThreadID)
    
    lEventHandle = CreateEvent(ByVal 0&, False, False, ByVal 0&)

    'Désactiver le bouton Start
    frmPrincipale.btnStart.Enabled = False
    frmPrincipale.btnStop.Enabled = True
    
End Sub

'*******************************************************
'Commandes exécutées lorsque le bouton Stop est cliqué
'Fin normale
'*******************************************************
Private Sub btnStop_Click()
    Dim lRC As Long

    'Crée un événement.  Le Thread vérifie sa présence pour se terminer correctement
    lRC = SetEvent(lEventHandle)

    'Une fois que le thread s'est arrèté correctement on le kill
    If lThreadHandle1 > 0 Then
        Call TerminateThread(lThreadHandle1, ByVal 0&)
    End If

    lThreadHandle1 = 0

    'Activer le bouton Start
    frmPrincipale.btnStart.Enabled = True
    frmPrincipale.btnStop.Enabled = False
    
    
    If blnFichEcrit = False Then
        blnFichEcrit = True
        EcrireLog
    End If
    
End Sub

'********************************************************
' Module exécuté lorsque la fenêtre se ferme avec le "X"
' Fin forcée
'********************************************************
Private Sub Form_Unload(Cancel As Integer)

    If lThreadHandle1 > 0 Then
        Call TerminateThread(lThreadHandle1, ByVal 0&)
    End If
  
    If blnFichEcrit = False Then
        blnFichEcrit = True
        EcrireLog
    End If
    
    Call TerminateProcess(GetCurrentProcess, ByVal 0&)

End Sub

'*****************************************************
' Permet d'écrire une ligne de données du fichier log
'******************************************************
Public Sub EcrireLog()
    Dim strNomFich As String

    'Ouverture du fichier
    strNomFich = "C:\Documents and Settings\Mig1\Mes documents\Projets VB\NetUpDown\LogNetUpDown.txt"
    Open strNomFich For Append As #1

    EcrireEttLog

    'Écrit tous les éléments de la Combo Box
    For i = 0 To cmbLog.ListCount
        Write #1, "" & cmbLog.List(i)
    Next i
    
    'Vide la ComboBox
    cmbLog.Clear
    
    'Ferme le fichier.
    Close #1

End Sub

'*****************************************************
' Permet d'écrire les lignes d'entête du fichier log
'******************************************************
Public Sub EcrireEttLog()
    
    Write #1, "--------------------------------------------"
    Write #1, "Statut d'internet + Date et heure du système"
    Write #1, "--------------------------------------------"
    Write #1,   ' Écrit une ligne vierge.
    
End Sub

--------------------------------------------------------------------

Voici le code ajouté dans un module nommé "modNetUpDown.bas" :

-------------------------------------------------------------------
'************************************************************
'  Règles à respecter lors de l'utilisation de thread       *
'************************************************************
' 1) La déclaration des fonctions doit se faire dans un     *
'    module.  Elles doivent être publiques.                 *
'                                                           *
' 2) Toute fonction appelée avec, en paramêtre, AddressOf   *
'    doit être définie dans un module.                      *
'************************************************************

Option Explicit
'******************************************************************************************************
'I tried this function but must search for another function because this one does not work correctly.
'It returns true when :
'   - the power plug of my external modem is put in
'   - the power plug of my external modem is take out
'It only returns false when :
'   - I force my firewall to block the internet access to this application
'******************************************************************************************************
'PING
'Private Declare Function InternetCheckConnection Lib "wininet.dll" _
'    Alias "InternetCheckConnectionA" _
'    (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
        
'Crée un Thread
Public Declare Function CreateThread Lib "kernel32" _
    (ByVal lpThreadAttributes As Any, ByVal dwStackSize As Long, _
     ByVal lpStartAddress As Long, lpParameter As Any, _
     ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
    
'WAIT
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    ' Sleep 1 seconde
        ' Sleep 1000
    ' Sleep 5 secondes
        ' Sleep 5000
    
'Termine un Thread
Public Declare Function TerminateThread Lib "kernel32" _
    (ByVal hThread As Long, ByVal dwExitCode As Long) As Long

'Termine un processus
Public Declare Function TerminateProcess Lib "kernel32" _
    (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

'Obtient le processus courrant
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long

'Attente d'un signal
Public Declare Function WaitForSingleObject Lib "kernel32.dll" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    
'Crée un événement
Public Declare Function CreateEvent& Lib "kernel32" _
    Alias "CreateEventA" _
    (ByVal lpEventAttributes As Long, _
     ByVal bManualReset As Long, ByVal bInitialState As Long, _
     ByVal lpname As String)

'Affecte un événement
Public Declare Function SetEvent Lib "kernel32" (ByVal hEvent As Long) As Long

'*****************************************************
' Déclaration des variables globales
'*****************************************************
Public lThreadHandle1 As Long
Public lEventHandle As Long

'*****************************************************
' Module exécuté lorsque la fenêtre est chargée
'*****************************************************
Public Sub Main()

    frmPrincipale.Show

End Sub

'*****************************************************
' Module du traitement principal
' Traitement du thread
'*****************************************************
Public Sub VerifNet()
    
    Dim lretCod         As Long
    Dim blnAllPingOK    As Boolean
    Dim blnOldStatusUp  As Boolean
    Dim strNetStatus    As String
    Dim intIndex        As Integer
                  
    intIndex = 0
                      
    'Déterminer si le net est up
    blnAllPingOK = PingAllSite
    If blnAllPingOK Then
        blnOldStatusUp = True
        strNetStatus = "UP  "
    Else
        blnOldStatusUp = False
        strNetStatus = "DOWN"
    End If

    'On inscrit le statut de départ
    Call InscrireLog(intIndex, strNetStatus)
    
    'Répétition du traitement jusqu'a ce que le bouton "Stop soit cliqué"
    Do
        'Attendre 30 secondes (30000 millisecondes) avant de refaire la vérification
        Sleep (30000)
        
        'Déterminer si le net est up
        blnAllPingOK = PingAllSite
        'Si le statut change, on inscrit au log
        If blnAllPingOK Then
            If blnOldStatusUp = False Then
               blnOldStatusUp = True
               strNetStatus = "UP  "
               Call InscrireLog(intIndex, strNetStatus)
            End If
        Else
            If blnOldStatusUp Then
               blnOldStatusUp = False
               strNetStatus = "DOWN"
               Call InscrireLog(intIndex, strNetStatus)
            End If
        End If
        
        DoEvents
        'Vérifie aux 5 secondes si le bouton "STOP" a créé un événement pour que le thread s'arrète normalement
        lretCod = WaitForSingleObject(lEventHandle, 5000)
    
     Loop Until lretCod = 0
    
End Sub

'*****************************************************************
'Fait un PING à 3 sites.  Si au moins une réponse, le net est UP
'*****************************************************************
Public Function PingAllSite() As Boolean

    Dim intRepSite1 As Integer
    Dim intRepSite2 As Integer
    Dim intRepSite3 As Integer

    'Faire un "PING" à 3 sites différents
    intRepSite1 = ModPing.Ping("www.videotron.com")
    intRepSite2 = ModPing.Ping("www.microsoft.com")
    intRepSite3 = ModPing.Ping("www.google.com")

    'Si un des 3 sites répond, le net est "UP"
    If intRepSite1 >= 0 Or intRepSite2 >= 0 Or intRepSite3 >= 0 Then
       PingAllSite = True
    Else
       PingAllSite = False
    End If

End Function

'*****************************************************************
'Inscrire une ligne au log (cumulet les infos dans une ComboBox
'*****************************************************************
Public Sub InscrireLog(ByRef intIdx As Integer, ByVal strStatus As String)
    Dim strDatHre As String
    Dim strItem As String
    
    'Obtenir la date et l'heure du système
    strDatHre = "" & Now
    'Afficher le nouveau statut et la date/heure
    frmPrincipale.txtNetStatut.Text = strStatus
    frmPrincipale.txtDateHre.Text = strDatHre
    'Ajouter un record à écrire au log
    intIdx = intIdx + 1
    strItem = "" & strStatus & " - " & strDatHre & intIdx
    frmPrincipale.cmbLog.AddItem strItem

End Sub

----------------------------------------------------------------
L'erreur se situe lors de l'appel de la fonction "GetHostByName" qui est appelée par la fonction "Ping".  Ce que je ne comprends pas, c'est pourquoi ce code ne fonctionne pas lorsqu'il est appelé dans un thread  Il fonctionne correctement dans le projet précédent (Ping.vbp)!!!

Y a t'il quelque-chose que je ne fait pas correctement?
Les thread ont t'ils des particularités, contraintes spéciales

Merci beaucoup!