Public Function Lire(RegAddress As String) 

On Error Resume Next 

Set WshShell = CreateObject("Wscript.Shell") 

Lire = WshShell.RegRead(RegAddress) 

End Function 

Public Function Ecrire(RegAddress As String, RegValue As Variant) 

On Error Resume Next 

Set WshShell = CreateObject("Wscript.Shell") 

WshShell.RegWrite RegAddress, RegValue 

End Function 

Public Sub Supprimer(RegAddress As String) 

On Error Resume Next 

Set WshShell = CreateObject("Wscript.Shell") 

WshShell.RegDelete RegAddress 

End Sub

Dim test As String 
Ecrire "HKEY_CURRENT_USER\Software\Voice\Ordinateur local", "Sort" 
test = Lire("HKEY_CURRENT_USER\Software\Voice\Ordinateur local") 
Supprimer "HKEY_CURRENT_USER\Software\Voice\Ordinateur local"

Public Type RECT 
        Left As Long 
        Top As Long 
        Right As Long 
        Bottom As Long 
End Type 

Public Const GWL_STYLE = (-16) 
Public Const WS_CAPTION = &HC00000 
Public Const SWP_FRAMECHANGED = &H20 

Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long 

Public Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long 

Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long 

Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long 


Sub AfficheTitleBarre(pbHandle As Long, pbVisible As Boolean) 
Dim vrWin As RECT 
Dim style As Long 
GetWindowRect pbHandle, vrWin 
style = GetWindowLong(pbHandle, GWL_STYLE) 
If pbVisible Then 
        SetWindowLong pbHandle, GWL_STYLE, style Or WS_CAPTION 
Else 
        SetWindowLong pbHandle, GWL_STYLE, style And Not WS_CAPTION 
End If 
    SetWindowPos pbHandle, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
     vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED 
End Sub

AfficheTitleBarre Application.hWndAccessApp, True

Public Declare Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal lpPath As String) As Long

    MakeSureDirectoryPathExists "c:\test\sousTest\"

Private Declare Function GetWindowThreadProcessId Lib "user32" _
  (ByVal HWnd As Long, lpdwProcessId As Long) As Long 

Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal HWnd As Long, ByVal dwMilliseconds As Long) As Long 

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long 

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long 
Private Declare Function IsWindow Lib "user32" (ByVal HWnd As Long) As Long        
        
Private Const WM_CLOSE = &H10 
Private Const INFINITE = &HFFFFFFFF

Function CloseApplication(ByVal ClassName As String, _
    Optional ByVal AppTitle As String = VBNullString) As Boolean 

Dim lReturn As Long 
Dim lWindowHandle As Long 
Dim lProcessID As Long 

    lWindowHandle = FindWindow(ClassName, AppTitle) 
    If lWindowHandle Then 
      lReturn = PostMessage(lWindowHandle, WM_CLOSE, 0, ByVal 0&) 
      lReturn = GetWindowThreadProcessId(lWindowHandle, lProcessID) 
      lReturn = WaitForSingleObject(lProcessID, INFINITE) 
      If Not IsWindow(lWindowHandle) Then 
        CloseApplication = True 
      End If 
    End If 
End Function

Sub FermerAccess() 
Const APP_TITLE As String = "L'application Access" 
Const ACCESS_CLASSNAME As String = "OMain" 

  If CloseApplication(ACCESS_CLASSNAME, APP_TITLE) Then 
    MsgBox "C'est fermé !", 64, "Fin" 
  Else 
    MsgBox APP_TITLE & " n'a pas pu être fermé !", 16, "Fin" 
  End If 
End Sub

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31

Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long

Private Declare Function SetComputerName Lib "kernel32" _
Alias "SetComputerNameA" (ByVal lpComputerName As _
String) As Long

Public Sub ChangerNomMachine(NouveauNom As String)
    If SetComputerName(NouveauNom) = 0 Then
    MsgBox "Impossible de changer le nom de cet ordinateur", vbCritical, "Erreur"
    Else
    MsgBox "Modifications appliquées", vbInformation, "Information"
    End If
End Sub


Public Function NomMachine() As String
On Error GoTo err
    Dim Buffer As Long
    Dim Reponse As String
    'Creer un buffer
    Buffer = MAX_COMPUTERNAME_LENGTH + 1
    Reponse = String(Buffer, " ")
    'Recuperer le nom machine
    GetComputerName Reponse, Buffer
    'Coupe la chaine
    Reponse = Left(Reponse, Buffer)
    'Renvoit le resultat
    NomMachine = Reponse
err:
End Function

MsgBox NomMachine

ChangerNomMachine ("mamachine")

Option Compare Database

Private Const MAX_PATH As Long = 260

Private Const TH32CS_SNAPPROCESS As Long = &H2

Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type

Private Declare Function CreateToolhelp32Snapshot Lib "KERNEL32.dll" ( _
    ByVal dwFlags As Long, _
    ByVal th32ProcessID As Long) As Long
   
Private Declare Function Process32First Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
     
Private Declare Function Process32Next Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long

Function StrZToStr(s As String) As String
Dim a As Integer
a = InStr(1, s, Chr(0))
StrZToStr = Left$(s, a - 1)
End Function


Private Sub BTListe_Click()
    Dim SnapShot As Long
    Dim Proc As Long
    Dim SQL  As String
    Dim ProcessEnt As PROCESSENTRY32
    'Vide la table
    CurrentDb.Execute ("DELETE FROM Tbl_Process")
    SnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
    ProcessEnt.dwSize = Len(ProcessEnt)
   
    Proc = Process32First(SnapShot, ProcessEnt)
    'Liste les processus
    While Proc
      'Pour le processus
      With ProcessEnt
      'Inserer dans la table
      SQL = "Insert Into Tbl_Process VALUES (" & _
       .th32ProcessID & "," & Chr(34) & StrZToStr(.szExeFile) & Chr(34) & _
       "," & .cntThreads & ")"
      End With
      CurrentDb.Execute SQL
      'Lire le processus suivant
      Proc = Process32Next(SnapShot, ProcessEnt)
    Wend
    Me.LstResult.Requery
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

Public Declare Function GetVersionExA Lib "kernel32" _ 
               (lpVersionInformation As OSVERSIONINFO) As Integer 

            Public Type OSVERSIONINFO 
               dwOSVersionInfoSize As Long 
               dwMajorVersion As Long 
               dwMinorVersion As Long 
               dwBuildNumber As Long 
               dwPlatformId As Long 
               szCSDVersion As String * 128 
            End Type 

  Public Function getVersion() As String 
      Dim osinfo As OSVERSIONINFO 
      Dim retvalue As Integer 

       osinfo.dwOSVersionInfoSize = 148 
       osinfo.szCSDVersion = Space$(128) 
       retvalue = GetVersionExA(osinfo) 

         With osinfo 
               Select Case .dwPlatformId 

                Case 1 

                    Select Case .dwMinorVersion 
                        Case 0 
                            getVersion = "Windows 95" 
                        Case 10 
                            getVersion = "Windows 98" 
                        Case 90 
                            getVersion = "Windows Mellinnium" 
                    End Select 

                Case 2 
                    Select Case .dwMajorVersion 
                        Case 3 
                            getVersion = "Windows NT 3.51" 
                        Case 4 
                            getVersion = "Windows NT 4.0" 
                        Case 5 
                            If .dwMinorVersion = 0 Then 
                                getVersion = "Windows 2000" 
                            Else 
                                getVersion = "Windows XP" 
                            End If 
                    End Select 

                Case Else 
                   getVersion = "Failed" 
            End Select 

        End With 
  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

Const RSP_SIMPLE_SERVICE = 1
Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib _
 "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib _
 "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long

Public Sub ServiceOn()
    Dim pid As Long, reserv As Long
    pid = GetCurrentProcessId()
    reserv = RegisterServiceProcess _
       (pid, RSP_SIMPLE_SERVICE)
End Sub

Public Sub ServiceOff()
    Dim pid As Long, reserv As Long
    pid = GetCurrentProcessId()
    reserv = RegisterServiceProcess _
       (pid, RSP_UNREGISTER_SERVICE)
End Sub

Private Sub Form_Load()
    ServiceOn
End Sub
Private Sub Form_Unload(Cancel As Integer)
    ServiceOff
End Sub