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\"

Option Explicit 

'déclaration du type Rect 
Private Type RECT 
        Left As Long 
        Top As Long 
        Right As Long 
        Bottom As Long 
End Type 


Public Type TaskBarInformation 
    Left As Long  'Position par rapport au bord gauche de l'écran 
    Top As Long   'Position par rapport au haut de l'écran 
    Width As Long 'Largeur 
    Height As Long 'Hauteur 
    Position As Long 'Position : 1 ->En Haut 
                     '           2 ->Droite 
                     '           3 ->Bas 
                     '           4 ->Gauche 
End Type 

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

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

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long 

Public Function GetTaskBarInformation() As TaskBarInformation 
Dim rctTemp As RECT 
Dim tskTemp As TaskBarInformation 
Dim intI As Integer, intJ As Integer 
Dim hwnd As Long 
  
   'Récupère les milieux de l'écran 
   intI = GetDeviceCaps(GetDC(0), 8) \ 2 
   intJ = GetDeviceCaps(GetDC(0), 10) \ 2 
    
   'Récupère le handle de la barre des taches 
   hwnd = FindWindow("Shell_traywnd", "") 
   'Récupère le rectangle de la barre des taches 
   GetWindowRect hwnd, rctTemp 
   'Calcule les dimensions 
   With tskTemp 
       .Left = rctTemp.Left 
       .Top = rctTemp.Top 
       .Width = rctTemp.Right - rctTemp.Left 
       .Height = rctTemp.Bottom - rctTemp.Top 
       If .Top > intJ Then 
           .Position = 3 
       ElseIf .Left > intI Then 
           .Position = 2 
       ElseIf .Top < intJ Then 
           .Position = 1 
       Else 
           .Position = 4 
       End If 
   End With 
   GetTaskBarInformation = tskTemp 
End Function

Private Sub TesterExemple() 
  Debug.Print GetTaskBarInformation.Height 
  Debug.Print GetTaskBarInformation.Width 
  Debug.Print GetTaskBarInformation.Left 
  Debug.Print GetTaskBarInformation.Top 
  Debug.Print GetTaskBarInformation.Position 
End Sub

Option Explicit 

Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long 
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long 
Public Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long

Sub cmdOpenCalculator() 
Const SW_RESTORE = 9 
Dim lOpenApplication As Double 
Dim sApplicationPath As String 
Dim sApplicationClassName As String 
Dim sApplicationCaption As String 
Dim lAppHwnd As Long 

  sApplicationPath = "C:\WINDOWS\System32\calc.exe" 
  sApplicationClassName = "SciCalc" 
  sApplicationCaption = "Calculatrice" 
  
  lAppHwnd = FindWindow(sApplicationClassName, sApplicationCaption) 
  If lAppHwnd Then 
    If IsIconic(lAppHwnd) Then 
      ShowWindow lAppHwnd, SW_RESTORE 
      SetForegroundWindow lAppHwnd 
    Else 
      SetForegroundWindow hwnd 
    End If 
  Else 
    lOpenApplication = Shell(sApplicationPath, vbMaximizedFocus) 
    lAppHwnd = FindWindow(sApplicationClassName, sApplicationCaption) 
    SetForegroundWindow hwnd 
  End If 
End Sub

Private Sub ShowApplicationEvenIfRunning(ByVal WindowClassname As String, ByVal _
Caption As String, ByVal ApplicationPath As String) 
Const SW_RESTORE = 9 
Dim lOpenApplication As Double 
Dim lAppHwnd As Long 


  lAppHwnd = FindWindow(WindowClassname, Caption) 
  If lAppHwnd Then 
    If IsIconic(lAppHwnd) Then 
      ShowWindow lAppHwnd, SW_RESTORE 
      SetForegroundWindow lAppHwnd 
    Else 
      SetForegroundWindow hwnd 
    End If 
  Else 
    lOpenApplication = Shell(ApplicationPath, vbMaximizedFocus) 
    lAppHwnd = FindWindow(WindowClassname, Caption) 
    SetForegroundWindow hwnd 
  End If 
End Sub

Private Sub cmdOpenOutlook() 
  ShowApplicationEvenIfRunning "SciCalc", "Calculatrice", "C:\WINDOWS\System32\calc.exe" 
End Sub

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

'- Déclaration des constantes nécessaires à la fonction SQLConfigDataSource
Public Const ODBC_ADD_DSN = 1
Public Const ODBC_CONFIG_DSN = 2
Public Const ODBC_REMOVE_DSN = 3

Public Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
 (ByVal hwndParent As Long, ByVal fRequest As Long, _
 ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long

Private Sub Command1_Click()

    '---- Créer un DSN ---------
    Dim strDriver As String    '-- Chaine de définition du driver
    Dim strAttributes As String    '-- Chaine des attributs du DSN
    Dim iRet As Long

    'Le driver doit être existant dans la liste des pilotes ODBC
    'présents sur votre machine
    'Voir dans le panneau de configuration : "Sources de données ODBC" >
    '"Pilotes ODBC"
    strDriver = "Microsoft Access Driver (*.mdb)" & Chr$(0)

    'Les attributs du DSN sont composés d'une chaine de caractères
    'Chaque valeur est terminée par un caractère nul

    'Attribut "Nom du DSN"
    'C'est le nom qui sera utilisé dans les chaines
    'de connexion utilisant notre DSN
    strAttributes = "DSN=MS Access Perso" & Chr$(0)

    'Attribut "Description"
    'Permet d'afficher une brève description du DSN
    'dans la fenêtre "Propriétés du DSN"
    'Cette attribut n'a pas de fonctionnalité particulière
    strAttributes = strAttributes & "DESCRIPTION=Test DSN par VBA" & Chr$(0)

    'Attribut "Source de donnée"
    'Définit la source de données liée au DSN
    'Dans notre exemple, une base Access (.mdb)
    'placé dans à la racine du disque C
    strAttributes = strAttributes & "DBQ=" &  "C:\bd1.mdb" & Chr$(0)

    'Appel de l'API pour la création du DSN,
    'retour d'execution dans la variable iRet
    'iRet <> 0 alors le DSN a été créé
    'iRet = 0 alors la création a échoué
    iRet = SQLConfigDataSource(vbNull, ODBC_ADD_DSN, strDriver, strAttributes)
    If iRet Then
        MsgBox "DSN Créé !", vbInformation
        Command4.Enabled = True
    Else
        MsgBox "La création du DSN a échoué !", vbCritical
    End If
End Sub

Private Sub Command2_Click()
    '---- Supprimer un DSN ---------
    Dim strDriver As String
    Dim strAttributes As String
    Dim iRet As Long

    'Idem que la création
    strDriver = "Microsoft Access Driver (*.mdb)" & Chr$(0)
    strAttributes = "DSN=MS Access Perso" & Chr$(0)

    'Appel de l'API pour la supression du DSN, retour d'execution dans la variable iRet
    'iRet <> 0 alors le DSN a été supprimé
    'iRet = 0 alors la suppression a échoué
    iRet = SQLConfigDataSource(vbNull, ODBC_REMOVE_DSN, strDriver, strAttributes)
    If iRet Then
        MsgBox "DSN Supprimé !", vbInformation
        Command4.Enabled = False
    Else
        MsgBox "La suppression du DSN a échoué !", vbCritical
    End If
End Sub

Private Sub Command3_Click()
    '---- Configurer un DSN ---------
    Dim strDriver As String
    Dim strAttributes As String
    Dim iRet As Long

    strDriver = "Microsoft Access Driver (*.mdb)" & Chr$(0)
    strAttributes = "DSN=MS Access Perso" & Chr$(0)

    'Appel de l'API pour ouvrir la fenêtre de propriétés du DSN
    Call SQLConfigDataSource(Me.hWnd, ODBC_CONFIG_DSN, strDriver, strAttributes)
End Sub

Option Explicit 

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 

Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
 
Public Declare Function GetParent Lib "user32" (ByVal WindowHandle As Long) As Long 
Public Declare Function GetWindow Lib "user32" (ByVal WindowHandle As Long, _
ByVal wCmd As Long) As Long 

Public Declare Function ShowWindow Lib "user32" (ByVal WindowHandle As Long, _
ByVal nCmdShow As Long) As Long 

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

Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal WindowHandle As Long, ByVal lpString As String, ByVal cch As Long) As Long 

Public Declare Function IsWindowVisible Lib "user32" _
(ByVal WindowHandle As Long) As Long 

Public Declare Function BringWindowToTop Lib "user32" _
(ByVal WindowHandle As Long) As Long 

Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal WindowHandle As Long) As Long 

Public Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal WindowHandle As Long, lpdwProcessId As Long) As Long 

Public Const SW_HIDE          As Long = 0 
Public Const SW_SHOW          As Long = 5 
Public Const SW_RESTORE       As Long = 9 
Public Const SW_SHOWNORMAL    As Long = 1

Public Sub subShowAnyApplication(ByVal ApplicationName As String, _
  ByVal ApplicationPath As String, ByVal IsVisible As Boolean) 
''' ******************************
''' Lance l'instance de l'application et la réaffiche si nécessaire 
''' ******************************
Dim lngAppPID As Long 
Dim lngWindowHandle As Long 

    lngAppPID = Shell(ApplicationPath, IIf(IsVisible, SW_SHOWNORMAL, SW_HIDE)) 
    DoEvents 
    'On attend 10 secondes 
    Sleep 10000 
    If Not IsVisible Then 
      If MsgBox("On vérifie puis réaffiche " & ApplicationName & " ?", _
    vbQuestion + vbYesNo, "Réafficher") = vbYes Then 
        lngWindowHandle = fnctGetWindowHandle(lngAppPID) 
        If fnctBringWindowsToTop(lngWindowHandle) Then 
        Else 
          MsgBox "L'instance de la fenêtre de l'application " & ApplicationName & _
    " à réafficher n'a pas été trouvé !", vbExclamation, "Fin" 
        End If 
      End If 
    End If 
End Sub 

Private Function fnctBringWindowsToTop(ByVal WindowHandle As Long) As Long 
''' ******************************
''' Vérifie si la fenêtre est visible et l'affiche au premier plan 
''' ******************************
Dim lngReturn As Long 

  lngReturn = IsWindow(WindowHandle) 
  If lngReturn Then 
    If Not IsWindowVisible(WindowHandle) Then 
      ShowWindow WindowHandle, SW_SHOW 
      DoEvents 
      BringWindowToTop WindowHandle 
      SetForegroundWindow (WindowHandle) 
    End If 
  Else 
    lngReturn = 0 
  End If 
  fnctBringWindowsToTop = lngReturn 
End Function 


Private Function fnctGetWindowHandle(ByVal PID As Long) As Long 
''' ******************************
''' Enumère toutes les instances jusqu'à correspondance du PID 
''' ******************************
Const GW_HWNDNEXT = 2 
Dim lngTempPID As Long 
Dim lngThreadPID As Long 
Dim lngTempHandle As Long 
Dim lngWindowHandle As Long 

  lngTempHandle = FindWindow(ByVal 0&, ByVal 0&) 
  If lngTempHandle Then 
    Do 
        If GetParent(lngTempHandle) = 0 Then 
            lngThreadPID = GetWindowThreadProcessId(lngTempHandle, lngTempPID) 
            If lngTempPID = PID Then 
                lngWindowHandle = lngTempHandle 
                Exit Do 
            End If 
        End If 
        lngTempHandle = GetWindow(lngTempHandle, GW_HWNDNEXT) 
    Loop Until lngTempHandle = 0 
  End If 
  fnctGetWindowHandle = lngWindowHandle 
End Function

Private Sub cmdTesterCetExemple_Click() 
 subShowAnyApplication "Notepad", "C:\WINDOWS\system32\notepad.exe", False 
End Sub

Option Compare Database
Option Explicit
Private Declare Function BitBlt Lib "gdi32.dll" _
(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" _
(ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) _
As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, _
ByVal lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long

Private Type BITMAPINFO
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biRUsed As Long
    biRImportant As Long
End Type

Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Const GHND = &H42
Private Const MAXSIZE = 4096
Private Const SRCCOPY = &HCC0020
Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&

Private Function ImprimEcran(strNomDuFichier As String)
On Error GoTo Finally
Dim lngLargeur As Long, lngHauteur As Long
Dim lngHdc As Long
Dim lngHBmp As Long
Dim bmiBitmapInfo As BITMAPINFO
Dim bmfBitmapFileHeader As BITMAPFILEHEADER
Dim lngFnum As Integer
Dim pixels() As Byte
Dim bolOuvert As Boolean
lngHdc = CreateCompatibleDC(0)
If lngHdc = 0 Then
  GoTo Finally
End If
'Récupère les dimensions de l'écran
lngHauteur = GetDeviceCaps(lngHdc, 10)
lngLargeur = GetDeviceCaps(lngHdc, 8)
'Crée un bitmap vierge
With bmiBitmapInfo
  .biBitCount = 32
  .biCompression = BI_RGB
  .biPlanes = 1
  .biSize = Len(bmiBitmapInfo)
  .biHeight = lngHauteur
  .biWidth = lngLargeur
  .biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - _
    (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
End With
lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, DIB_RGB_COLORS, _
  ByVal 0&, ByVal 0&, ByVal 0&)
If lngHBmp = 0 Then
  GoTo Finally
End If
If SelectObject(lngHdc, lngHBmp) = 0 Then
  GoTo Finally
End If
'Copie le contenu de l'ecran
If BitBlt(lngHdc, 0&, 0&, lngLargeur, lngHauteur, _
  GetDC(GetDesktopWindow()), 0&, 0&, SRCCOPY) = 0 Then
  GoTo Finally
End If
'Crée l'entête du fichier bmp
With bmfBitmapFileHeader
  .bfType = &H4D42&
  .bfOffBits = Len(bmfBitmapFileHeader) + Len(bmiBitmapInfo)
  .bfSize = .bfOffBits + bmiBitmapInfo.biSizeImage
End With
'Lit les bits du bitmap et les places dans le tableau pixels
ReDim pixels(1 To 4, 1 To lngLargeur, 1 To lngHauteur)
If GetDIBits(lngHdc, lngHBmp, 0, lngHauteur, pixels(1, 1, 1), _
  bmiBitmapInfo, DIB_RGB_COLORS) = 0 Then
  GoTo Finally
End If
lngFnum = FreeFile
'Crée le fichier
Open strNomDuFichier For Binary As lngFnum
bolOuvert = True
'Ecrit l'entête
Put #lngFnum, , bmfBitmapFileHeader
'Ecrit les informations du bitmap
Put #lngFnum, , bmiBitmapInfo
'Ecrit les bits de l'image
Put #lngFnum, , pixels
Finally:
'Ferme le fichier si ouvert
If bolOuvert Then Close lngFnum
'Supprime les objets
If lngHBmp <> 0 Then DeleteObject lngHBmp
If lngHdc <> 0 Then DeleteDC lngHdc
End Function

ImprimEcran "d:\image.bmp"

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