Option Compare Database
'Déclaration de la constante définissant un lecteur reseau
Private Const RESOURCETYPE_DISK As Long = &H1&
'Déclaration des fonctions de l'api windows
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias _
  "WNetAddConnection2A" (lpNetResource As NETRESOURCE, _
  ByVal lpPassword As String, ByVal lpUserName As String, _
  ByVal dwFlags As Long) As Long
 
Private Declare Function WNetCancelConnection Lib "mpr.dll" Alias _
  "WNetCancelConnectionA" (ByVal lpszName As String, _
  ByVal bForce As Long) As Long
'Déclaration du type NetResource (nécessaire pour la fonction WnetAddConnection)
Private Type NETRESOURCE
    dwScope As Long
    dwType As Long
    dwDisplayType As Long
    dwUsage As Long
    lpLocalName As String
    lpRemoteName As String
    lpComment As String
    lpProvider As String
End Type
 
Public Function ConnecterLecteur(strChemin As String, strLettre As String, _
  Optional strUtilisateur As String, Optional strMotDePasse As String) As Boolean
Dim RessourceReseau As NETRESOURCE
'Déclare et paramètre la ressource réseau
With RessourceReseau
  .lpRemoteName = strChemin
  .lpLocalName = strLettre
  .dwType = RESOURCETYPE_DISK
End With
'Tente la connexion et retourne vrai en cas de succès
ConnecterLecteur = WNetAddConnection2(RessourceReseau, strMotDePasse, strUtilisateur, 0) = 0
End Function
 
Public Function DeconnecterLecteur(strLettre As String, _
  Optional bolForce As Boolean = False) As Boolean
'Deconnecte et retourne la réponse
DeconnecterLecteurReseau = WNetCancelConnection(strLettre, IIf(bolForce, 1, 0)) = 0
End Function

Sub test()
ConnecterLecteur "\\Secretariat01\DonneesPartagees", "z:", "secretaire", "secè[@po1"
End Sub

Sub test()
DeconnecterLecteur "z:"
End Sub

Option Compare Database
 
Option Explicit
 
'definition des constantes
Private Const IP_STATUS_BASE As Long = 11000
Private Const IP_SUCCESS As Long = 0
Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
Private Const IP_NO_RESOURCES As Long = (11000 + 6)
Private Const IP_BAD_OPTION As Long = (11000 + 7)
Private Const IP_HW_ERROR As Long = (11000 + 8)
Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
Private Const IP_BAD_REQ As Long = (11000 + 11)
Private Const IP_BAD_ROUTE As Long = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
Private Const IP_ADDR_DELETED As Long = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
Private Const IP_MTU_CHANGE As Long = (11000 + 21)
Private Const IP_UNLOAD As Long = (11000 + 22)
Private Const IP_ADDR_ADDED As Long = (11000 + 23)
Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
Private Const MAX_IP_STATUS As Long = (11000 + 50)
Private Const IP_PENDING As Long = (11000 + 255)
Private Const PING_TIMEOUT As Long = 500
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
  'Type de données Winsock
Private Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Long
    wMaxUDPDG As Long
    dwVendorInfo As Long
End Type
 
'type d'options ICMP
Private Type ICMP_OPTIONS
    Ttl As Byte  'Time to live
    Tos As Byte
    Flags As Byte 'options
    OptionsSize As Byte
    OptionsData As Long
End Type
 
 
'Packet de reponse ICMP
Public Type ICMP_ECHO_REPLY
    Address As Long
    status As Long
    RoundTripTime As Long
    DataSize As Long
    'Reserved As Integer --> prévu mais pas encore implementé???
    DataPointer As Long
    Options As ICMP_OPTIONS
    Data As String * 250
End Type
 
'Type adresse
Private Type HOSTENT
    hName As Long 'nom
    hAliases As Long 'alias
    hAddrType As Integer 'type adresse
    hLen As Integer 'longueur --> IP6 supporté???
    hAddrList As Long
End Type
'GetHostByName --> cette fonction va nous permettre de
'résoudre le nom d'hote en adresse IP
Private Declare Function gethostbyname Lib "wsock32" _
    (ByVal hostname As String) As Long
 
'Fonction de copie memoire de la librairie Kernel
Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" _
    (xDest As Any, _
    xSource As Any, _
    ByVal nbytes As Long)
 
'fonction longueur String du Kernel
Private Declare Function lstrlenA Lib "kernel32" _
    (lpString As Any) As Long
 
 
'demarrage du Winsock
Private Declare Function WSAStartup Lib "wsock32" _
    (ByVal wVersionRequired As Long, _
    lpWSADATA As WSADATA) As Long
 
'fonction de nettoyage du protocole Winsock pour eviter les conflits possibles
Private Declare Function WSACleanup Lib "wsock32" () As Long
 
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
 
'fermeture du handle ICMP
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
    (ByVal IcmpHandle As Long) As Long
 
 
'envoi du packet echo
    Private Declare Function IcmpSendEcho Lib "icmp.dll" _
    (ByVal IcmpHandle As Long, _
    ByVal DestinationAddress As Long, _
    ByVal RequestData As String, _
    ByVal RequestSize As Long, _
    ByVal RequestOptions As Long, _
    ReplyBuffer As ICMP_ECHO_REPLY, _
    ByVal ReplySize As Long, _
    ByVal Timeout As Long) As Long
 
 
'Fonction permettant la conversion en representation longue de l'Adresse IP
    Private Declare Function inet_addr Lib "wsock32" _
    (ByVal s As String) As Long
 
'Fonction de Ping
 
Public Function Ping(sAddress As String, _
    sDataToSend As String, _
    ECHO As ICMP_ECHO_REPLY) As Long
 
    'Si le ping réussit, le resultat va contenir les données suivantes:
    '.RoundTripTime = temps d'aller-retour en millisecondes
    '.Data = données retournées
    '(les memes qu'on a envoyé en principe) terminé par Null
    '.Address = adresse IP qui a veritablement repondu (alias possibles)
    '.DataSize = sizeOf(.data)
    '.Status = 0 si le ping a réussi
    'Si le ping echoue le .ping contiendra le code d'erreur
 
 
    Dim hPort As Long
    Dim dwAddress As Long
 
    'conversion de l'adresse au format quad long
    dwAddress = inet_addr(sAddress)
 
    'si dwAdresse est invalide, la constante INADDR_NONE est retournée
    If dwAddress <> INADDR_NONE Then
        'ouverture d'un port ICMP
        hPort = IcmpCreateFile()
        'et si ca marche, on lance l'echo.
        If hPort Then
     
            Call IcmpSendEcho(hPort, _
                dwAddress, _
                sDataToSend, _
                Len(sDataToSend), _
                0, _
                ECHO, _
                Len(ECHO), _
                PING_TIMEOUT)

            'on recupere le statut pour voir si on a réussi
            Ping = ECHO.status
            'close the port handle
            Call IcmpCloseHandle(hPort)

        End If 'se rapportant au "If hPort"
     
    Else:
 
        'l'adresse a été mal specifiée

        Ping = INADDR_NONE

    End If  'se rapportant au  If dwAddress <> INADDR_NONE
End Function
 
'cette fonction va nous permettre de determiner la réussite ou non du ping,
'et le cas écheant de trouver l'erreur...
Public Function GetStatusCode(status As Long) As String
 
Dim msg As String
 
    Select Case status
    Case IP_SUCCESS: msg = "ip success"
    Case INADDR_NONE: msg = "inet_addr: bad IP format"
    Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"
    Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"
    Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
    Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
    Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
    Case IP_NO_RESOURCES: msg = "ip no resources"
    Case IP_BAD_OPTION: msg = "ip bad option"
    Case IP_HW_ERROR: msg = "ip hw_error"
    Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"
    Case IP_REQ_TIMED_OUT: msg = "ip req timed out"
    Case IP_BAD_REQ: msg = "ip bad req"
    Case IP_BAD_ROUTE: msg = "ip bad route"
    Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"
    Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"
    Case IP_PARAM_PROBLEM: msg = "ip param_problem"
    Case IP_SOURCE_QUENCH: msg = "ip source quench"
    Case IP_OPTION_TOO_BIG: msg = "ip option too_big"
    Case IP_BAD_DESTINATION: msg = "ip bad destination"
    Case IP_ADDR_DELETED: msg = "ip addr deleted"
    Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"
    Case IP_MTU_CHANGE: msg = "ip mtu_change"
    Case IP_UNLOAD: msg = "ip unload"
    Case IP_ADDR_ADDED: msg = "ip addr added"
    Case IP_GENERAL_FAILURE: msg = "ip general failure"
    Case IP_PENDING: msg = "ip pending"
    Case PING_TIMEOUT: msg = "ping timeout"
    Case Else: msg = "unknown msg returned"
    End Select
 
    GetStatusCode = CStr(status) & " [ " & msg & " ]"
End Function
 
'conversion nom d'hote --> adresse IP
Public Function GetIPFromHostName(ByVal sHostName As String) As String

    Dim nbytes As Long
    Dim ptrHosent As Long  'pointeur vers la structure "adresse hote"
    Dim ptrName As Long    'pointeur vers le  Nom d'hote
    Dim ptrAddress As Long 'adresse du pointeur
    Dim ptrIPAddress As Long 'pointeur vers l'adresse IP
    Dim sAddress As String

    sAddress = Space$(4)

    ptrHosent = gethostbyname(sHostName & vbNullChar)
    If ptrHosent <> 0 Then

        'on assigne l'adresse et l'offset du pointeur
        'ptrName est le nom officiel de l'hote

        ptrName = ptrHosent

        'liste des adresses de l'hote terminée par un Null
        'l'adresse est à 12 octets du demarrage...

        ptrAddress = ptrHosent + 12

        'on recupere l'adresse IP

        CopyMemory ptrName, ByVal ptrName, 4
        CopyMemory ptrAddress, ByVal ptrAddress, 4
        CopyMemory ptrIPAddress, ByVal ptrAddress, 4
        CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4

        GetIPFromHostName = IPToText(sAddress)

    End If
End Function
 
 
'fonction permettant de convertir une IP en txt
 
Public Function IPToText(ByVal IPAddress As String) As String
 
    IPToText = CStr(Asc(IPAddress)) & "." & _
      CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
      CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
      CStr(Asc(Mid$(IPAddress, 4, 1)))
 
End Function
'Convertit une IP binaire en texte
Public Function ConvertIp(Ip As Long)
    Dim i As Integer
    Dim strTemp As String
    strTemp = Format(Hex(Ip), "00000000")
    For i = 7 To 1 Step -2
        ConvertIp = ConvertIp & ConvertHexToDec(Mid(strTemp, i, 2)) & "."
    Next i
    ConvertIp = Left(ConvertIp, Len(ConvertIp) - 1)
End Function
 
Private Function ConvertHexToDec(N As String) As String
    ConvertHexToDec = Format(CLng("&H" & N), "000")
End Function
 
'routine de nettoyage du socket
Public Sub SocketsCleanup()
    If WSACleanup() <> 0 Then
        MsgBox "Erreur lors du nettoyage du socket.", vbCritical
    End If
End Sub

'Procedure d'initialisation du socket
Public Function SocketsInitialize() As Boolean
 
    Dim WSAD As WSADATA
    SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function

Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Long
Dim success As Long
Dim sIPAddress As String
If Nz(txtHote, "") = "" And Nz(txtIPSend, "") = "" Then
    MsgBox "Veuillez spécifié une destination"
Else
    If SocketsInitialize() Then
        'Si le nom d'hote est spécifié,
        If Nz(txtHote, "") <> "" Then
            'convertit le nom d'hote en adresse IP
            sIPAddress = GetIPFromHostName(txtHote)
        Else
            sIPAddress = txtIPSend
        End If
        'lance le ping en envoyant la chaine sépcifiée
        'dans la zone de texte txtDataSend
        success = Ping(sIPAddress, Nz(txtDataSend, vbNullString), ECHO)

        'Affiche le résultat
        txtResult = GetStatusCode(success)
        txtIPReceive = ConvertIp(ECHO.Address)
        txtTime = ECHO.RoundTripTime & " ms"
        'Affiche la réponse reçue en retirant le caractère de
        'fin de chaine
        If Left$(ECHO.Data, 1) <> Chr$(0) Then
            pos = InStr(ECHO.Data, Chr$(0))
            txtDataReceive = Left$(ECHO.Data, pos - 1)
        End If

        txtMemory = ECHO.DataPointer
        'Libère le socket
        SocketsCleanup

    Else
        MsgBox "Les fonctionnalités de ping sont indisponibles"
    End If
End If

Dim ctltxt As Control
For Each ctltxt In Me.Controls
  If TypeOf ctltxt Is TextBox And ctltxt.Name <> "txtHote" Then _
    ctltxt = ""
Next

Private Function Lire(RegAddress As String)
On Error Resume Next
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.Shell")
Lire = WshShell.RegRead(RegAddress)
End Function
 
Function GetFireFoxPath()
Dim strVersion As String
' Cherche la version actuelle de FireFox
strVersion = Lire("HKEY_CURRENT_USER\Software\Mozilla\Mozilla Firefox\CurrentVersion")
strVersion = Left(strVersion, InStr(strVersion, " ") - 1)
' Va lire la clé correspondant à la version actuelle
GetFireFoxPath = Lire("HKEY_CURRENT_USER\Software\Mozilla\Mozilla Firefox " & _
  strVersion & "\bin\PathToExe")
End Function

Sub ouvrir()
Shell GetFireFoxPath & " " & Chr(34) & "http://www.developpez.com" & Chr(34)
End Sub

Dim objWMIService As Object
Dim colAdapters As Object
Dim strComputer As String
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer &"\root\cimv2")
Set colAdapters = _
    objWMIService.ExecQuery  ("SELECT * FROM Win32_NetworkAdapterConfiguration" & _
                                  "WHERE IPEnabled =True")
n = 1
For Each objAdapter In colAdapters
    debug.print objAdapter.MACAddress
    If Not IsNull(objAdapter.IPAddress) Then
        For i = 0 To UBound(objAdapter.IPAddress)
            debug.print objAdapter.IPAddress(i)
        Next
    End If
n = n + 1
Next

Option Compare Database
Option Explicit
 
Public IPAdresses       As New Collection
Public MacAddress       As String

Option Compare Database
Option Explicit
 
Private mstrComputerName    As String           'Nom du PC
Private mcolMacAddresses    As New Collection   'Liste des MacAdresses
 
'==============================================================================
'Procédure de recherche
'==============================================================================
Function Search() As String
    Dim objWMIService   As Object
    Dim colAdapters     As Object
    Dim objAdapter      As Object
    Dim objMacAddress   As MacAddress
    Dim i               As Long
    Dim s               As String
 
    Set objWMIService = GetObject("winmgmts:\\" & mstrComputerName & "\root\cimv2")
    Set colAdapters = _
        objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration " &  _
                 "WHERE IPEnabled =True")
 
    For Each objAdapter In colAdapters
        Set objMacAddress = New MacAddress
        objMacAddress.MacAddress = objAdapter.MacAddress
        If Not IsNull(objAdapter.IPAddress) Then
            For i = 0 To UBound(objAdapter.IPAddress)
                s = s & objMacAddress.MacAddress & vbTab & objAdapter.IPAddress(i) & _
                 vbCrLf
                objMacAddress.IPAdresses.Add objAdapter.IPAddress(i)
            Next
        End If
        mcolMacAddresses.Add objMacAddress
    Next
    Search = Left(s, Len(s) - Len(vbCrLf))
End Function
'==============================================================================
' Fonctions pour les mac adresses
'==============================================================================
Function Count() As Long
    Count = mcolMacAddresses.Count
End Function
 
Function Item(index) As MacAddress
    Set Item = mcolMacAddresses.Item(index)
End Function
 
'==============================================================================
'Nom du PC
'==============================================================================
Property Get ComputerName() As String
    ComputerName = mstrComputerName
End Property
Property Let ComputerName(NomDuPC As String)
    mstrComputerName = NomDuPC
End Property
 
'==============================================================================
'Initialisation de la classe
'==============================================================================
Private Sub Class_Initialize()
    mstrComputerName = "."
End Sub

    Dim x       As New MacAddresses
    Dim nMAC    As Long
    Dim nIP     As Long
    Debug.Print x.Search
    For nMAC = 1 To x.Count
        Debug.Print x.Item(nMAC).MacAddress
        For nIP = 1 To x.Item(nMAC).IPAdresses.Count
            Debug.Print vbTab & x.Item(nMAC).IPAdresses(nIP)
        Next
    Next

Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
 (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
 
 
 
Public Function fnctGetUNCPath(ByVal PathName As String) As String
Const MAX_UNC_LENGTH  As Integer = 512
Dim strUNCPath As String
Dim strTempUNCName As String
Dim lngReturnErrorCode  As Long
 
  strTempUNCName = String(MAX_UNC_LENGTH, 0)
  lngReturnErrorCode = WNetGetConnection(Left(PathName, 2), strTempUNCName, _
    MAX_UNC_LENGTH)
 
  If lngReturnErrorCode = 0 Then
     strTempUNCName = Trim(Left(strTempUNCName, InStr(strTempUNCName, vbNullChar) - 1))
     strUNCPath = strTempUNCName & Mid(PathName, 3)
  End If
 
fnctGetUNCPath = strUNCPath
End Function

MsgBox fnctGetUNCPath("U:\Argyronet\OneAnyFile.txt")

Option Compare Database
Option Explicit
Private Declare Sub PathStripPath Lib "shlwapi.dll" Alias "PathStripPathA" _
   (ByVal pszPath As String)
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
                   "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
   (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
 
 
 'Structure du fichier
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
 'Constantes
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
 
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
 
 
Public Function OuvrirUnFichier(Handle As Long, _
 Titre As String, _
 TypeRetour As Byte, _
 Optional TitreFiltre As String, _
 Optional TypeFichier As String, _
 Optional RepParDefaut As String, _
 Optional UNC As Boolean = False) As String
 'OuvrirUnFichier est la fonction a utiliser dans votre formulaire pour ouvrir _
 'la boîte de dialogue de sélection d'un fichier.
 'Explication des paramètres
    'Handle = le handle de la fenêtre (Me.Hwnd)
    'Titre = Titre de la boîte de dialogue
    'TypeRetour (Définit la valeur, de type String, renvoyée par la fonction)
        '1 = Chemin complet + Nom du fichier
        '2 = Nom fichier seulement
    'TitreFiltre = Titre du filtre
        'Exemple: Fichier Access
        'N'utilisez pas cet argument si vous ne voulez spécifier aucun filtre
    'TypeFichier = Extention du fichier (Sans le .)
        'Exemple: MDB
        'N'utilisez pas cet argument si vous ne voulez spécifier aucun filtre
    'RepParDefaut = Répertoire d'ouverture par defaut
        'Exemple: C:\windows\system32
        'Si vous laissé l'argument vide, par defaut il se place dans
        'le répertoire de votre application
    'UNC = Définit le chemin retourné
        'Vrai : Chemin UNC \\serveur\partage\dossier\fichier
        'Faux : Chemin local Disque\dossier\fichier
Dim StructFile As OPENFILENAME
Dim sFiltre As String
 
 'Construction du filtre en fonction des arguments spécifiés
If Len(TitreFiltre) > 0 And Len(TypeFichier) > 0 Then
  sFiltre = TitreFiltre & " (" & TypeFichier & ")" & Chr$(0) & _
    "*." & TypeFichier & Chr$(0)
End If
sFiltre = sFiltre & "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0)
 
 
 'Configuration de la boîte de dialogue
  With StructFile
    .lStructSize = Len(StructFile) 'Initialisation de la grosseur de la structure
    .hwndOwner = Handle 'Identification du handle de la fenêtre
    .lpstrFilter = sFiltre 'Application du filtre
    .lpstrFile = String$(254, vbNullChar) 'Initialisation du fichier '0' x 254
    .nMaxFile = 254 'Taille maximale du fichier
    .lpstrFileTitle = String$(254, vbNullChar) 'Initialisation du nom du fichier '0' x 254
    .nMaxFileTitle = 254  'Taille maximale du nom du fichier
    .lpstrTitle = Titre 'Titre de la boîte de dialogue
    .flags = OFN_HIDEREADONLY  'Option de la boite de dialogue
    If ((IsNull(RepParDefaut)) Or (RepParDefaut = "")) Then
        RepParDefaut = CurrentDb.Name
        PathStripPath (RepParDefaut)
        .lpstrInitialDir = Left(CurrentDb.Name, Len(CurrentDb.Name) - _
 Len(Mid$(RepParDefaut, 1, InStr(1, RepParDefaut, vbNullChar) - 1)))
        Else: .lpstrInitialDir = RepParDefaut
    End If
  End With
 
If (GetOpenFileName(StructFile)) Then 'Si un fichier est sélectionné
    Select Case TypeRetour
      Case 1
      OuvrirUnFichier = Trim$(Left(StructFile.lpstrFile, _
  InStr(1, StructFile.lpstrFile, vbNullChar) - 1))
      If UNC Then OuvrirUnFichier = fnctGetUNCPath(OuvrirUnFichier)
      Case 2: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFileTitle, _
  InStr(1, StructFile.lpstrFileTitle, vbNullChar) - 1))
    End Select
  End If
 
End Function
 
 
 
 
Private Function fnctGetUNCPath(ByVal PathName As String) As String
Const MAX_UNC_LENGTH  As Integer = 512
Dim strUNCPath As String
Dim strTempUNCName As String
Dim lngReturnErrorCode  As Long
 
  strTempUNCName = String(MAX_UNC_LENGTH, 0)
  lngReturnErrorCode = WNetGetConnection(Left(PathName, 2), strTempUNCName, MAX_UNC_LENGTH)
 
  If lngReturnErrorCode = 0 Then
     strTempUNCName = Trim(Left(strTempUNCName, InStr(strTempUNCName, vbNullChar) - 1))
     strUNCPath = strTempUNCName & Mid(PathName, 3)
  End If
 
fnctGetUNCPath = strUNCPath
End Function

MsgBox OuvrirUnFichier(0, "Choisir un fichier", 1, , , , True)

Option Compare Database
Option Explicit
 
 
'Fonction pour ouvrir une connexion Internet :
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
        (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, _
         ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
 
'Fonction pour fermer le handle de la connexion :
Public Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
 
'Fonction pour ouvrir une adresse URL :
Public 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
 
'Fonction pour lire les données d'une URL :
Public Declare Function InternetReadFile Lib "wininet.dll" _
        (ByVal hFile As Long, ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, _
         lNumberOfBytesRead As Long) As Integer
 
Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0   ' utiliser info de config de la base de registre
Public Const INTERNET_FLAG_EXISITING_CONNECT = &H20000000
Public Const INTERNET_FLAG_RELOAD = &H80000000
 
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private total As Long
Private Nb As Long
Dim hSession As Long
 
Public Sub openInter()
    hSession = InternetOpen("MonApp", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    total = 0
    Nb = 0
End Sub
 
Public Sub closeInter()
    InternetCloseHandle (hSession)
End Sub
 
 
Public Sub GetWeblog(ByVal url As String, ByVal strFic As String)
 
    ' pointeur du lien lien
    Dim hUrlFile As Long
    Dim bBoucle As Boolean
    ' bloc de lecture par buffer 4 096 caractères
    Dim sReadBuf As String * 4096
    Dim OctetsLus As Long
    ' pointeurs des fichiers
    Dim localFile As Long
    ' chronométrage du temps d'exécution
    Dim t0 As Single, t1 As Single
 
    t0 = GetTickCount()
 
    ' ouverture des ressources de navigation internet
    openInter
 
    ' désignation d'un pointeur de fichier libre
    localFile = FreeFile
 
    ' si le fichier existe déjà on l'efface
    If Len(Dir(strFic)) > 0 Then Kill strFic
 
    ' ouverture du fichier en mode binaire
    Open strFic For Binary As #localFile
 
    ' ouverture de l'url
    hUrlFile = InternetOpenUrl(hSession, url, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
 
    bBoucle = True
    While bBoucle
        sReadBuf = ""
        ' lecture par bloc de 4096 caractères
        bBoucle = InternetReadFile(hUrlFile, sReadBuf, 4096&, OctetsLus)
        ' écriture par bloc dans le fichier local
        Put #localFile, , Left(sReadBuf, OctetsLus)
        If OctetsLus = 0 Then bBoucle = False
        DoEvents
    Wend
    ' fermeture du fichier local
    Close #localFile
    ' fermeture des ressources de navigation
    closeInter
 
    t1 = GetTickCount()
    Debug.Print "téléchargement du xml : "; Format((t1 - t0) / 1000, "0.000") & " s"
 
    ' parsing XML du fichier nous verrons ce point plus tard dans l'article
    xmlParser strFic
 
End Sub

GetWeblog "http://www.developpez.com", "d:\fichierTemp.txt"

' ----------------------------------------------------------------------
' 1 Déclaration Functions de l'API Windows Fichiers
' ----------------------------------------------------------------------
' -----------------------
' 1.a Les Constantes
' -----------------------
Const MAX_PATH = 260
Const INVALID_HANDLE_VALUE = -1
 
' File Attributes
Const FILE_ATTRIBUTE_READONLY = &H1          '    1
Const FILE_ATTRIBUTE_HIDDEN = &H2            '    2
Const FILE_ATTRIBUTE_SYSTEM = &H4            '    4
Const FILE_ATTRIBUTE_DIRECTORY = &H10        '   16
Const FILE_ATTRIBUTE_ARCHIVE = &H20          '   32
Const FILE_ATTRIBUTE_ENCRYPTED = &H40        '   64
Const FILE_ATTRIBUTE_NORMAL = &H80           '  128
Const FILE_ATTRIBUTE_TEMPORARY = &H100       '  256
Const FILE_ATTRIBUTE_SPARSE_FILE = &H200     '  512
Const FILE_ATTRIBUTE_REPARSE_POINT = &H400   ' 1024
Const FILE_ATTRIBUTE_COMPRESSED = &H800      ' 2048
Const FILE_ATTRIBUTE_OFFLINE = &H1000        ' 4096
 
' File Creation flags
Const CREATE_NEW = 1
Const CREATE_ALWAYS = 2
Const OPEN_EXISTING = 3
Const OPEN_ALWAYS = 4
Const TRUNCATE_EXISTING = 5
 
' FormatMessage
Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" ( _
         ByVal dwFlags As Long, ByVal lpSource As Long, _
         ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
         ByVal lpBuffer As String, ByVal nSize As Long, _
         ByVal Arguments As Long) As Long
 
' -----------------------
' 1.b Les Fonctions
' -----------------------
Private Declare Function OpenFile Lib "kernel32.dll" Alias "OpenFileA" _
        (ByVal lpFileName As String, ByVal lpReOpenBuff As Long, _
         ByVal uStyle) As Long
 
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" ( _
        ByVal lpFileName As String, ByVal dwAccess As Long, _
        ByVal dwShareMode As Long, ByVal lpSecurityAttr As Long, _
        ByVal dwCreationDisposition As Long, _
        ByVal dwFlagAndAttr As Long, ByVal hTemplateFile As Long) As Long
 
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hHandle As Long) As Long
 
Private Declare Function WriteFile Lib "kernel32.dll" ( _
        ByVal hFile As Long, ByVal buffer As String, _
        ByVal dwBytesToWrite As Long, ByRef lpdwBytesWritten As Long, _
        ByVal lpOverlapped As Long) As Long
 
' ----------------------------------------------------------------------
' 2 Déclaration Functions de l'API Windows Internet/ftp
' ----------------------------------------------------------------------
' -----------------------
' 2.a Les Constantes
' -----------------------
Const INTERNET_FLAG_TRANSFER_ASCII = &H1      ' 0x00000001
Const FTP_TRANSFER_TYPE_ASCII = &H1           ' 0x00000001
Const INTERNET_FLAG_TRANSFER_BINARY = &H2     ' 0x00000002
Const FTP_TRANSFER_TYPE_BINARY = &H2          ' 0x00000002
Const GENERIC_READ = &H80000000               ' (0x80000000L)
Const GENERIC_WRITE = &H40000000              ' (0x40000000L)
Const INTERNET_FLAG_RAW_DATA = &H40000000     ' FTP/gopher find: receive the item _
	'as raw (structured) data
 
Const INTERNET_DEFAULT_FTP_PORT = 21          ' default for FTP servers
Const INTERNET_DEFAULT_GOPHER_PORT = 70       '    "     "  gopher "
Const INTERNET_DEFAULT_HTTP_PORT = 80         '    "     "  HTTP   "
Const INTERNET_DEFAULT_HTTPS_PORT = 443       '    "     "  HTTPS  "
Const INTERNET_DEFAULT_SOCKS_PORT = 1080      ' default for SOCKS firewall servers.
 
' access types for InternetOpen()
Const INTERNET_OPEN_TYPE_PRECONFIG = 0                     ' use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1                        ' direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3                         ' via named proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4   ' prevent using java/script/INS
 
' service types for InternetConnect()
Const INTERNET_SERVICE_URL = 0
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_SERVICE_GOPHER = 2
Const INTERNET_SERVICE_HTTP = 3
 
'Query Info
Const HTTP_QUERY_STATUS_CODE = 19  ' Status Code returned by Server
Const HTTP_QUERY_STATUS_TEXT = 20  '
 
' -----------------------
' 2.b Les Fonctions
' -----------------------
 
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 HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" _
                (ByVal hconnect As Long, ByVal lpszVerb As String, ByVal lpszObjectName As String, _
                 ByVal lpszVersion As String, ByVal lpszReferer As Long, _
				 ByVal lpszAcceptTypes As Long, ByVal dwFlags As Long, _
				 ByVal dwContext As Long) As Long
 
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" _
                (ByVal hRequest As Long, ByVal lpszHeaders As String, ByVal dwHdrLength As Long, _
                 ByVal lpOptional As String, ByVal dwOptionalLength As Long) As Long
' HttpSendRequest sans lpOptional As String.
' à la place on met lpOptional As Long, pour pouvoir passer un pointeur NULL
Private Declare Function HttpSendRequest2 Lib "wininet.dll" Alias "HttpSendRequestA" _
                (ByVal hRequest As Long, ByVal lpszHeaders As Long, ByVal dwHdrLength As Long, _
                 ByVal lpOptional As Long, ByVal dwOptionalLength As Long) As Long
 
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" _
                (ByVal hRequest As Long, ByVal dwInfoLevel As Long, _
                 ByVal lpvBuffer As String, ByRef lpdwBufferLength As Long, _
				 ByRef lpdwIndex As Long) As Long
 
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
                 (ByVal hconnect As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, _
                  ByVal dwHdrLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
 
Private Declare Function InternetOpenUrl2 Lib "wininet.dll" Alias "InternetOpenUrlA" _
                 (ByVal hconnect As Long, ByVal lpszUrl As String, ByVal lpszHeaders As Long, _
                  ByVal dwHdrLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
 
Private Declare Function InternetReadFileVBA Lib "wininet.dll" Alias "InternetReadFile" _
                (ByVal hFile As Long, ByVal lpBuffer As String, _
                 ByVal dwNbBytesToRead As Long, ByRef lpdwNbBytesRead As Long) As Long
 
Private Declare Function InternetQueryDataAvailable Lib "wininet.dll" _
                (ByVal hFile As Long, ByRef lpdwNumberOfBytesAvailable As Long, _
                 ByVal dwFlags As Long, dwContext As Long) As Long
' hFile : retourné par InternetOpenUrl ou FtpOpenFile ou HttpOpenRequest ou GopherOpenFile
 
' ---------------------------------------------------------------------------------
' Lecture fichier http par blocs et HTTPrequest
' - InternetOpen
'  - InternetConnect
'   - HttpOpenRequest
'    - HttpSendRequest
'
' Paramètre 1 : URL http
' Paramètre 2 : Cible (chemin complet + Nom)
' ---------------------------------------------------------------------------------
Sub Lecture_fichierHTTP(httpURL As String, strCible As String)
 
    ' Internet Handles for Internet Session, Internet Connection, HTTP Request
    Dim hInternetSess As Long, hIConnect As Long, httpReq As Long
    ' File Handle (Windows)
    Dim hFile As Long
    ' Read/Writte buffer
    Const BUFSIZE = 1024
    Dim buffer As String, ErrBuffer As String, ErrNum As Long
    Dim qryBuffer As String, qryBufLength As Long, qryIndex As Long
    '
    Dim BytesAvailable As Long, strSvrResponseCode As String
    Dim BytesToRead As Long, BytesRead As Long
    Dim BytesToWrite As Long, BytesWritten As Long
    Dim strServer As String, strObjPathName As String
    Dim RemoteFileSize As Long, localFileSize As Long
    Dim oRegEx As RegExp, oMatches As MatchCollection, oMatch As Match
    '
    Dim RetVal As Long, p As Long, strErrMsg As String, strHttpErrDesc As String
 
    ' HTTP/1.1 http URL Syntax
    ' http_URL  = "http:" "//" host [ ":" port ] [ abs_path ]
    '   scheme = "http"
    '   abs_path = "/" + .....
 
    ' Coupe l'URL en deux parties : Serveur et chemin absolu
    Set oRegEx = New VBScript_RegExp_55.RegExp
    oRegEx.Pattern = "^(?:http://){0,1}([^/]*)(/.*)$"
    Set oMatches = oRegEx.Execute(httpURL)
    If oMatches.Count = 1 Then
       Set oMatch = oMatches.item(0)
       strServer = oMatch.SubMatches(0) & vbNullChar
       strObjPathName = oMatch.SubMatches(1) & vbNullChar
    Else
       MsgBox "L'URL http n'est pas correcte"
       Exit Sub
    End If
 
    On Error GoTo ERRH
 
    'Ouvre session internet - OK si valeur renvoyé<>0
    hInternetSess = InternetOpen("MonAppli", 0, vbNullString, vbNullString, 0)
    If hInternetSess = 0 Then err.Raise 1001
 
    'Connection au serveur HTTP - OK si valeur renvoyé<>0
    hIConnect = InternetConnect(hInternetSess, strServer, _
                INTERNET_DEFAULT_HTTP_PORT, vbNullChar, vbNullChar, INTERNET_SERVICE_HTTP, 0, 0)
    If hIConnect = 0 Then err.Raise 1002
 
    ' Prépare requête HTTP - OK si valeur renvoyé <>0
    httpReq = HttpOpenRequest(hIConnect, "GET" & vbNullChar, strObjPathName, _
                 "HTTP/1.1" & vbNullChar, 0, _
                 0, 0, 0)
    If httpReq = 0 Then err.Raise 1003
 
    ' Envoie Requête HTTP - OK valeur renvoyée 1
    RetVal = HttpSendRequest2(httpReq, 0, 0, 0, 0)
    If RetVal <> 1 Then err.Raise 1004
 
    ' Examine Code envoyé par serveur
    ' "2xx"=succedd ("200"=OK), "3xx" = Redirection, 4xx Client Error ("404" = Non trouvé)
    qryBuffer = String(512, vbNullChar): qryBufLength = 512
    ' fonction HttpQueryInfo - OK si valeur renvoyé 1
    RetVal = HttpQueryInfo(httpReq, HTTP_QUERY_STATUS_CODE, qryBuffer, qryBufLength, qryIndex)
    If RetVal = 1 Then
       strSvrResponseCode = left(qryBuffer, 3)
    Else
       err.Raise 1005
    End If
 
    ' Erreur si serveur répond avec 4xx ou 5xx
    If strSvrResponseCode Like "[4,5]??" Then err.Raise 1006
 
    ' Nbre d'octets à prêts à lire. (<>Total à lire)
    'RetVal = InternetQueryDataAvailable(httpReq, BytesAvailable, 0, 0)
 
    ' Ouvre fichier local
    hFile = CreateFile(strCible & vbNullChar, GENERIC_WRITE, 0, 0, _
            CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = 0 Then err.Raise 1007
 
    localFileSize = 0
    BytesToRead = BUFSIZE
 
    ' Boucle sur fichier distant
    buffer = String(BUFSIZE + 1, vbNullChar)
    Do
      RetVal = InternetReadFileVBA(httpReq, buffer, BytesToRead, BytesRead)  'VarPtr(BytesRead)
      If RetVal = 1 Then
         BytesToWrite = BytesRead
      Else
         err.Raise 1031
      End If
      If BytesToWrite > 0 Then
         RetVal = WriteFile(hFile, buffer, BytesToWrite, BytesWritten, 0)
         localFileSize = localFileSize + BytesWritten
      End If
    Loop While BytesRead > 0
 
 
END_SUB1:
    CloseHandle (hFile)                    'Ferme Fichier Local
 
END_SUB2:
    InternetCloseHandle httpReq            'Ferme handle requête HTTP _
	'(fichier distant dans cette fonction)
    InternetCloseHandle hIConnect          'Ferme Connection Internet
    InternetCloseHandle hInternetSess      'Ferme Session internet
    Exit Sub
 
ERRH:
    ErrNum = err.LastDllError
    ' Liste des codes erreurs wininet.dll:
    ' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wininet/wininet/wininet_errors.asp
    Select Case err.Number
      Case 1001
           MsgBox "Echec ouverture session internet. Code erreur " & CStr(ErrNum)
      Case 1002
           MsgBox "Echec création connexion au serveur " & strServer & ". Code erreur " & CStr(ErrNum)
      Case 1003
           MsgBox "Echec préparation requête HTTP. Code erreur " & CStr(ErrNum)
      Case 1004
           MsgBox "Echec requête HTTP. Code erreur " & CStr(ErrNum) & ". Vérifiez l'URL"
      Case 1005
           MsgBox "Echec requête HTTP QUERY_STATUS_CODE. Code erreur " & CStr(ErrNum) & ". Vérifiez l'URL"
      Case 1006
           ' Le serveur a renvoyé un code 4xx ou 5xx
           Select Case CInt(strSvrResponseCode)
              Case 400: strHttpErrDesc = "Bad Request"
              Case 401: strHttpErrDesc = "Unauthorized"
              Case 402: strHttpErrDesc = "Payment Required"
              Case 403: strHttpErrDesc = "Forbidden"
              Case 404: strHttpErrDesc = "Not Found"
              Case 405: strHttpErrDesc = "Method Not Allowed"
              Case 406: strHttpErrDesc = "Not Acceptable"
              Case 407: strHttpErrDesc = "Proxy Authentication Required"
              Case 408: strHttpErrDesc = "Request Time-out"
              Case 409: strHttpErrDesc = "Conflict"
              Case 410: strHttpErrDesc = "Gone"
              Case 411: strHttpErrDesc = "Length Required"
              Case 412: strHttpErrDesc = "Precondition Failed"
              Case 413: strHttpErrDesc = "Request Entity Too Large"
              Case 414: strHttpErrDesc = "Request-URI Too Large"
              Case 415: strHttpErrDesc = "Unsupported Media Type"
              Case 500: strHttpErrDesc = "Internal Server Error"
              Case 501: strHttpErrDesc = "Not Implemented"
              Case 502: strHttpErrDesc = "Bad Gateway"
              Case 503: strHttpErrDesc = "Service Unavailable"
              Case 504: strHttpErrDesc = "Gateway Time-out"
              Case 505: strHttpErrDesc = "HTTP Version not supported"
           End Select
           strErrMsg = "Le serveur HTTP a répondu ave le code suivant : " & strSvrResponseCode
           If strHttpErrDesc <> "" Then
              strErrMsg = strErrMsg & " - " & strHttpErrDesc & vbCrLf
           Else
              strErrMsg = strErrMsg & "  (code non répertorié)" & vbCrLf
           End If
           strErrMsg = strErrMsg & "URL : " & httpURL
           MsgBox strErrMsg, , "Erreur HTTP"
      Case 1007
           MsgBox "Echec création fichier " & strCible
      Case 1031
           MsgBox "Erreur N° " & CStr(ErrNum) & " , pendant lecture HTTP" & strCible
      Case Else
           strErrMsg = "Erreur N° " & CStr(err.Number) & " - " & err.Description
           MsgBox strErrMsg
    End Select
 
    Resume END_SUB1
End Sub

Function GetHTML(ByVal LinkHTTP As String) As String
'---------------------------------------------------------------------------------------
' Procedure : GetHTML
' Créée le  : vendredi 27 mai 2005 15:15
' Auteur    : Maxence
' Objet     : Récupère le texte HTML d'une page Web
' Bibliothèque : Cette procédure nécessite la déclaration de la bibliothèque
'                'Microsoft XML v x.xx' - prenez la version la plus récente
'---------------------------------------------------------------------------------------
'
      'Définition des variables
      Dim oHttp As MSXML2.ServerXMLHTTP50
      Dim sTemp As String
      Dim nLimite As Long
 
      'Définition des constantes
      Const conStatutOK As Long = 200
 
      ' Instancier l'objet
      Set oHttp = New MSXML2.ServerXMLHTTP50
 
      With oHttp
        ' Se Connecter à la page web et récupérer l'information.
        .Open "GET", LinkHTTP, False
        .Send
       ' v = .getAllResponseHeaders
        sTemp = .responseText
        'Vérifier que tout s'est bien passé
        If Not .Status = conStatutOK Then Err.Raise 65000, "Procédure", "pas trouvé !"
      End With
    GetHTML = sTemp
    On Error Resume Next
    oHttp.abort
    Set oHttp = Nothing
End Function

Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Private Type QOCINFO
    dwSize As Long
    dwFlags As Long
    dwInSpeed As Long 'in bytes/second
    dwOutSpeed As Long 'in bytes/second
End Type
 
Private Declare Function IsDestinationReachable Lib _
"SENSAPI.DLL" Alias "IsDestinationReachableA" _
(ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long
 
Public Function testReseau(Nom As String) As Boolean
    Dim Ret As QOCINFO
    Ret.dwSize = Len(Ret)
    testReseau= (IsDestinationReachable(Nom, Ret) <>0)  
End Function

If TestReseau("www.developpez.com") then
 msgbox "Le meilleur site de developpement est accessible"
else
 msgbox "Veuillez réessayer plus tard"
end if

Function GetCleanHTML(ByVal sLink As String) As String
    'Déclarer les variables
    Dim oHttp   As MSXML2.XMLHTTP
    Dim sHTML   As String
    Dim i       As Long
 
    'Déclarer les constantes
    Const XMLHTTP_STATUSOK As Long = 200
    'Créer l'instance de l'objet
    Set oHttp = New MSXML2.XMLHTTP
 
    'Se connecter au site, et récupérer le code HTML
    With oHttp
        .Open "GET", sLink, False
        .send
        sHTML = .responseText
        'Vérifier que tout s'est bien passé
        If .Status = XMLHTTP_STATUSOK Then
            'Si oui, nettoyer le code HTML pour retirer tous les caractères bidons
            For i = 0 To 31
                sHTML = Replace(sHTML, Chr(i), "")
            Next
            sHTML = Replace(sHTML, "     ", " ")
            sHTML = Replace(sHTML, "    ", " ")
            sHTML = Replace(sHTML, "   ", " ")
            sHTML = Replace(sHTML, "  ", " ")
            sHTML = Replace(sHTML, "> <", "><")
 
            'Si non, vider shtml et  générer une erreur
        Else
            sHTML = ""
            Err.Raise 65000, "GetHTML", "Erreur lors de la récupération du HTML : " & oHttp.statusText
        End If
        GetCleanHTML = sHTML
        On Error Resume Next
        .abort
     End With
    Set oHttp = Nothing
End Function
 
Function GetIPFromHTML()
    'Cette procédure a été construite après un examen du code de la page passée en paramètre.
    'Elle n'est donc valide que pour cette page...
 
    'Déclaration des variables
    Dim sHTML_Base As String
    Dim i1 As Long
    Dim i2 As Long
 
    'Déclaration des constantes
    Const HTMLDEBUT As String = "l'adresse IP :</font><br><br><b>"
 
    'Récupérer le HTML propre de la page
    sHTML_Base = GetCleanHTML("http://www.anonymat.org/vostraces/index.php")
 
    'Trouver le début de l'adresse IP
    i1 = InStr(1, sHTML_Base, HTMLDEBUT, vbTextCompare) + Len(HTMLDEBUT)
 
    'Trouver la fin de l'adresse IP
    i2 = InStr(i1 + 1, sHTML_Base, "<")
 
    'Renvoyer l'adresse IP ainsi définie :
    GetIPFromHTML = Trim(Mid(sHTML_Base, i1, i2 - i1))
End Function