IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

Les meilleures sources Access

Les meilleures sources AccessConsultez toutes les sources

Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013 

 
OuvrirSommaireDiversFonctions système - Interactions Windows

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.

 
Sélectionnez
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:

 
Sélectionnez
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"
Créé le 28 janvier 2005  par AvigeilPro

Versions : 97 et supérieures

Il faut utiliser les Api windows.

 
Sélectionnez
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 :

 
Sélectionnez
AfficheTitleBarre Application.hWndAccessApp, True
Créé le 28 janvier 2005  par Didier L

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 :

 
Sélectionnez
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) :

 
Sélectionnez
MakeSureDirectoryPathExists "c:\test\sousTest\"

Une fois cette ligne exécutée, je suis sûr que mon répertoire sousTest existe dans c:\test.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur

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.

 
Sélectionnez
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 :

 
Sélectionnez
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
Créé le 8 octobre 2005  par Tofalu

Page de l'auteur

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:

 
Sélectionnez
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.

 
Sélectionnez
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:

 
Sélectionnez
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:

 
Sélectionnez
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
Créé le 20 mai 2005  par Argyronet

Page de l'auteur

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:

 
Sélectionnez
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):

 
Sélectionnez
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:

 
Sélectionnez
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
Créé le 28 janvier 2005  par Argyronet

Page de l'auteur

Versions : 97 et supérieures

Dans un module, placer le code suivant :

 
Sélectionnez
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 :

 
Sélectionnez
MsgBox NomMachine

Changer le nom de la machine :

 
Sélectionnez
ChangerNomMachine ("mamachine")
Créé le 5 février 2005  par Tofalu

Page de l'auteur

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 :

 
Sélectionnez
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.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

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 :

 
Sélectionnez
'- 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

 
Sélectionnez
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

 
Sélectionnez
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.

 
Sélectionnez
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
Créé le 20 mai 2005  par Thierry AIM

Page de l'auteur

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

 
Sélectionnez
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):

 
Sélectionnez
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 :

 
Sélectionnez
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...

Créé le 20 mai 2005  par Argyronet

Page de l'auteur

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 :

 
Sélectionnez
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&
 
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 :

 
Sélectionnez
ImprimEcran "d:\image.bmp"
Créé le 20 mai 2005  par Tofalu

Page de l'auteur

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.

 
Sélectionnez
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


Lien utile : Une source du forum VB

Créé le 28 janvier 2005  par ARO

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.

 
Sélectionnez
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
Créé le 5 mars 2005  par Shwin

Déclarer dans un module la fonction suivante :

 
Sélectionnez
Public Declare Function GetVolumeInformation Lib "Kernel32" Alias "GetVolumeInformationA" _ 
	(ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
	lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
	ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Code à placer sur l'évènement d'un bouton :

 
Sélectionnez
Dim Serial As Long, VName As String, FSName As String
VName = String$(255, Chr$(0))
FSName = String$(255, Chr$(0))
GetVolumeInformation "C:\", VName, 255, Serial, 0, 0, FSName, 255
VName = Left$(VName, InStr(1, VName, Chr$(0)) - 1)
FSName = Left$(FSName, InStr(1, FSName, Chr$(0)) - 1)
MsgBox "Le nom de volume de C:\ est '" + VName +  _
  "', le nom du fichier système de C:\ est '" + FSName + _ 
  "' et le numéro de série de C:\ est '" + Trim(Str$(Serial)) + "'", vbInformation + vbOKOnly
Créé le 15 novembre 2006  par Tofalu

Page de l'auteur

Voici un petit code utile permettant d'envoyer la valeur d'un controle vers le presse-papier de Windows. Ce code utilise les APIs de Windows.

Code à placer dans un module :

 
Sélectionnez
Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
 
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
'
 
Function ctrlC_copie(strcopie As String)
 
	Dim hGlobalMemory As Long, lpGlobalMemory As Long
    Dim hClipMemory As Long, X As Long
 
    hGlobalMemory = GlobalAlloc(GHND, Len(strcopie) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, strcopie)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
    	MsgBox "N'a pas pu ouvrir la zone de mémoire. La Copie est arrêtée."
		GoTo OutOfHere2
	End If
    If OpenClipboard(0&) = 0 Then
    	MsgBox "N'a pas pu ouvrir le Presse Papier. La Copie est arrêtée."
    	Exit Function
    End If
    X = EmptyClipboard()
 
	hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
	If CloseClipboard() = 0 Then
		MsgBox "N'a pu Fermer le Presse Papier"
	End If
 
End Function
Créé le 16 janvier 2007  par Dolphy35

Page de l'auteur

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 © 2013 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.