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"

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 Sub

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