IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
logo
Sommaire > Divers > Fonctions système - Interactions Windows
        Accéder à la base des registres
        Afficher/Masquer la barre de titre d'une fenêtre
        Créer une arborescence de répertoires complète
        Déterminer la taille et la position de la barre des taches
        Eviter les multi instances d'une application
        Fermer la fenêtre d'une application
        Lire et modifier le nom de l'ordinateur
        Lister les processus en cours d'exécution
        Manipulation de source ODBC par le code
        Réafficher une fenêtre lancée en mode cachée avec Shell
        Réaliser et sauvegarder une capture d'écran
        Récupérer le nom du système d'exploitation
        Transformer son application en service
        6.2.1. Boites de dialogue Windows(9)
                Afficher la fenêtre Arreter l'ordinateur
                Afficher la fenêtre Exécuter
                Afficher la boîte de dialogue de selection de police
                Afficher la boite de dialogue A propos
                Afficher une boite de dialogue ActiveDirectory
                Afficher une boite de dialogue de sélection de couleur
                Afficher une fenêtre de télechargement pour copier un fichier
                Afficher une msgbox avec l'API Windows
                Inviter l'utilisateur à redémarrer son ordinateur

rechercher
precedent    sommaire    suivant    telecharger


Auteur : AvigeilPro
Version : 28/01/2005
Accéder à la base des registres
Versions : 97 et supérieures

Ce code permet de lire, écrire et supprimer des clés dans la base de registre. Ces fonctions ont des limites dues à certains types de données.
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
Exemple d'utilisation:
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"

Auteur : Didier L
Version : 28/01/2005
Afficher/Masquer la barre de titre d'une fenêtre
Versions : 97 et supérieures

Il faut utiliser les Api windows.
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
Le premier paramètre est le Handle de la fenêtre, le second un booléen pour spécifier si la barre doit être affichée ou pas.
Un exemple : Masquer la barre de titre de la fenêtre Access :
AfficheTitleBarre Application.hWndAccessApp, True

Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur
Créer une arborescence de répertoires complète
Versions : 97 et supérieures

Cette fonction permet de créer une abrorescence de répertoires compléte sans avoir à se soucier si les répertoires parents existent.

Exemple je veux créer le repertoire C:\test\sousTest

Si le répertoire test n'existe pas, la fonction crée d'abord ce répertoire avant de créer le sous-répertoire sousTest. Cela représente un gain de temps considérable car il n'est pas nécessaire d'avoir à tester la présence ou non des répertoires parents.

Dans un module :
Public Declare Function MakeSureDirectoryPathExists _
Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Puis la fonction s'utilise ainsi (par exemple sur le clic d'un bouton) :
    MakeSureDirectoryPathExists "c:\test\sousTest\"
Une fois cette ligne exécutée, je suis sûr que mon répertoire sousTest existe dans c:\test.


Auteur : Tofalu
Version : 08/10/2005
Déterminer la taille et la position de la barre des taches
Versions : Access 2000 et supérieures

L'intérêt de cette procédure est de déterminer les coordonnées de la barre de tâches de Windows. Cela peut par exemple servir à définir la position d'un formulaire à ouvrir de manière à ce que ce dernier, même agrandi, ne recouvre pas la barre de tâches.
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
Exemple d'utilisation :
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

Auteur : Argyronet
Version : 20/05/2005
Page de l'auteur
Eviter les multi instances d'une application
Version : Access 97 et supérieures. Visual Basic 6

Ce code permet de vérifier si une instance d'une application est déjà ouverte auquel cas, la positionne au premier plan et sinon, l'ouvre en conséquence.

Cette procédure est un exemple qu'il vous faudra modifier à votre guise (les variables) pour l'adapter en conséquence de vos besoins. Ci-après (3), vous trouverez une procédure paramétrable. Il est recommandé de connaître le WindowClassName de votre application.

1- A déclarer dans un module:
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
2- Exemple de base:

Cet exemple vous montre comment interdire une double instance de la calculatrice Windows.
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
Où :

  • sApplicationPath : Chemin de l'application.
  • sApplicationClassName : ClassName de l'application
  • sApplicationCaption : Titre précis de la fenêtre de la calculatrice

3 - Exemple avec une procédure générique paramétrée:
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
Que vous utiliserez comme suit:
Private Sub cmdOpenOutlook() 
  ShowApplicationEvenIfRunning "SciCalc", "Calculatrice", "C:\WINDOWS\System32\calc.exe" 
End Sub
Liste des ClassName pour les Applications Office :

  • Word 97 - 2000 - XP : OpusApp
  • Excel 97 - 2000 - XP : XLMAIN
  • Access 97 - 2000 - XP : OMain
  • PowerPoint 95 : PP7FrameClass
  • PowerPoint 97 : PP97FrameClass
  • PowerPoint 2000 : PP9FrameClass
  • PowerPoint XP : PP10FrameClass
  • FrontPage 2000 - XP : FrontPageExplorerWindow40
  • Outlook 97 - 98 - 2000 - XP : rctrl_renwnd32
  • Project 98 - 2000 : JWinproj-WhimperMainClass
  • Visual Basic Editor : wndclass_desked_gsk


Auteur : Argyronet
Version : 28/01/2005
Page de l'auteur
Fermer la fenêtre d'une application
Versions : 97 et supérieures


Intérêt: Pouvoir fermer une application à partir d'une autre en fonction du nom de classe de fenêtre et, optionnellement du titre de la fenêtre

Déclaration des API's et des constantes:
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
Fonction permettant de générer la fermeture (True si Succès):
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
Mode d 'utilisation:
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
Liste des ClassName pour les Applications Office :

  • Word 97 - 2000 - XP : OpusApp
  • Excel 97 - 2000 - XP : XLMAIN
  • Access 97 - 2000 - XP : OMain
  • PowerPoint 95 : PP7FrameClass
  • PowerPoint 97 : PP97FrameClass
  • PowerPoint 2000 : PP9FrameClass
  • PowerPoint XP : PP10FrameClass
  • FrontPage 2000 - XP : FrontPageExplorerWindow40
  • Outlook 97 - 98 - 2000 - XP : rctrl_renwnd32
  • Project 98 - 2000 : JWinproj-WhimperMainClass
  • Visual Basic Editor : wndclass_desked_gsk


Auteur : Tofalu
Version : 05/02/2005
Page de l'auteur
Lire et modifier le nom de l'ordinateur
Versions : 97 et supérieures

Dans un module, placer le code suivant :
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
Utilisation :

Afficher le nom de la machine :
MsgBox NomMachine
Changer le nom de la machine :
ChangerNomMachine ("mamachine")

Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur
Téléchargez le zip
Lister les processus en cours d'exécution
Versions : 2000 et supérieures

Ce code permet de lister les processus en cours d'exécution. Pour ce faire, nous disposons d'une table Tbl_Process possédant 3 champs :

  • ID : Numérique
  • Fichier : Texte (255)
  • Thread : Numérique

Voici le code à placer dans un formulaire pour lister les processus dans une zone de liste :
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
Ici, comme vous l'aurez remarqué, l'exécution se produit lors d'un clique sur le bouton BTListe.

N'hésitez pas à télecharger le fichier zip pour visualiser le fonctionnement.


Auteur : Thierry AIM
Version : 20/05/2005
Manipulation de source ODBC par le code
Version : Access 97 et supérieures

Parfois, il est nécessaire de créer des DSN ODBC via du code VBA. Cet exemple vous montre comment créer une source de données nommée MS Access Perso utilisant le driver ODBC Access.

Dans un module, placez les lignes suivantes :
'- 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
I Création du DSN
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
II Suppression du DSN
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
III Configuration du DSN

Ces quelques lignes affichent la boite de dialogue Windows de configuration de DSN.
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

Auteur : Argyronet
Version : 20/05/2005
Page de l'auteur
Réafficher une fenêtre lancée en mode cachée avec Shell
Version : Access 97 et supérieures. Utilisable aussi sous Visual Basic

Permet de réafficher une application qui a été lancée depuis la fonction Shell() aprés un certain délai d'attente. Il faut savoir que pour exploiter la fenêtre d'une application, on a besoin de son Handle (HWnd). Malheureusement, la fonction Shell() retourne le PID (ProcessID) du programme lancé.

1- A déclarer dans un module (basApiDeclaration) :
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
2 - A déclarer dans une autre module (basWindowOperation):
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
Pour tester cet exemple, collez ce bout de code dans votre formulaire sur l'événement click d'un bouton nommé cmdTesterCetExemple :
Private Sub cmdTesterCetExemple_Click() 
 subShowAnyApplication "Notepad", "C:\WINDOWS\system32\notepad.exe", False 
End Sub
Cette procédure est un exemple qu'il vous faudra modifier à votre guise pour l'adapter en conséquence de vos besoins; Notamment la durée d'attente et bien entendu l'application et son état...


Auteur : Tofalu
Version : 20/05/2005
Page de l'auteur
Réaliser et sauvegarder une capture d'écran
Versions : Toutes

Cette procédure permet de capturer l'image de l'écran (l'équivalent de la touche Impécr Syst) et de la stocker dans un fichier bitmap.

Dans un nouveau module, placez les lignes suivantes :
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
Vous pourrez ainsi réaliser une capture de l'écran depuis n'importe quel évènement de n'importe quel objet de votre application à l'aide de :
ImprimEcran "d:\image.bmp"

Auteur : ARO
Version : 28/01/2005
Récupérer le nom du système d'exploitation
Versions : 97 et supérieures

Placer ce code dans un module, l'appel de la fonction GetVersion() renverra une chaîne de caractères indiquant l'OS.
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


Auteur : Shwin
Version : 05/03/2005
Transformer son application en service
Versions : 97 et supérieures

Cet exemple utilise les fonction de l'API Windows pour transformer l'application en service lors de son exécution. Ainsi, le processus de la base de données sera prioritaire dans la gestion des tâches de Windows et Access bénéficiera alors de plus de ressources allouées par le système d'exploitation.

Créer un formulaire qui sera masqué et qui se lancera au démarrage de l'application. C'est lui qui va nous permettre de savoir quand l'application se lance et quand elle s'arrête. En effet, la fermeture du formulaire caché signifiera que l'application est en phase de fermeture. Nous allons donc utiliser les événements Form_Load et Form_Unload de notre formulaire.
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

rechercher
precedent    sommaire    suivant    telecharger

Valid XHTML 1.1!Valid CSS!

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2005 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.