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



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 dûes à 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 : 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 fermerture (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
Auteur : ridan
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 :
Version : 27/08/2004
Récupérer l'adresse MAC de la machine en cours (solution 1)
Versions : 97 et supérieures

Dim objWMIService As Object Dim colAdapters As Object Dim strComputer As String strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer &"\root\cimv2") Set colAdapters = _ objWMIService.ExecQuery ("SELECT * FROM Win32_NetworkAdapterConfiguration" & _ "WHERE IPEnabled =True") n = 1 For Each objAdapter In colAdapters debug.print objAdapter.MACAddress If Not IsNull(objAdapter.IPAddress) Then For i = 0 To UBound(objAdapter.IPAddress) debug.print objAdapter.IPAddress(i) Next End If n = n + 1 Next

Auteur : Maxence Hubiche
Version : 27/08/2004
Récupérer l'adresse MAC de la machine en cours (solution 2)
Versions : 2000 et supérieures

Dans un module de classe MacAddress

Option Compare Database Option Explicit Public IPAdresses As New Collection Public MacAddress As String
Dans un module de classe MacAddresses

Option Compare Database Option Explicit Private mstrComputerName As String 'Nom du PC Private mcolMacAddresses As New Collection 'Liste des MacAdresses '============================================================================== 'Procédure de recherche '============================================================================== Function Search() As String Dim objWMIService As Object Dim colAdapters As Object Dim objAdapter As Object Dim objMacAddress As MacAddress Dim i As Long Dim s As String Set objWMIService = GetObject("winmgmts:\\" & mstrComputerName & "\root\cimv2") Set colAdapters = _ objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration " & _ "WHERE IPEnabled =True") For Each objAdapter In colAdapters Set objMacAddress = New MacAddress objMacAddress.MacAddress = objAdapter.MacAddress If Not IsNull(objAdapter.IPAddress) Then For i = 0 To UBound(objAdapter.IPAddress) s = s & objMacAddress.MacAddress & vbTab & objAdapter.IPAddress(i) & _ vbCrLf objMacAddress.IPAdresses.Add objAdapter.IPAddress(i) Next End If mcolMacAddresses.Add objMacAddress Next Search = Left(s, Len(s) - Len(vbCrLf)) End Function '============================================================================== ' Fonctions pour les mac adresses '============================================================================== Function Count() As Long Count = mcolMacAddresses.Count End Function Function Item(index) As MacAddress Set Item = mcolMacAddresses.Item(index) End Function '============================================================================== 'Nom du PC '============================================================================== Property Get ComputerName() As String ComputerName = mstrComputerName End Property Property Let ComputerName(NomDuPC As String) mstrComputerName = NomDuPC End Property '============================================================================== 'Initialisation de la classe '============================================================================== Private Sub Class_Initialize() mstrComputerName = "." End Sub
Pour utiliser ces classes (par exemple)

Dim x As New MacAddresses Dim nMAC As Long Dim nIP As Long Debug.Print x.Search For nMAC = 1 To x.Count Debug.Print x.Item(nMAC).MacAddress For nIP = 1 To x.Item(nMAC).IPAdresses.Count Debug.Print vbTab & x.Item(nMAC).IPAdresses(nIP) Next Next

Auteur : ARO
Version : 28/01/2005
Récuperer 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 chaine 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 : Tofalu
Version : 05/03/2005
Page de l'auteur
Tester la présence dun PC sur le réseau
Ce code utilise l'API Windows ISDestinationReachable pour déterminer si un PC est accessible via le réseau.

Const NETWORK_ALIVE_AOL = &H4 Const NETWORK_ALIVE_LAN = &H1 Const NETWORK_ALIVE_WAN = &H2 Private Type QOCINFO dwSize As Long dwFlags As Long dwInSpeed As Long 'in bytes/second dwOutSpeed As Long 'in bytes/second End Type Private Declare Function IsDestinationReachable Lib _ "SENSAPI.DLL" Alias "IsDestinationReachableA" _ (ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long Public function testReseau(Nom as String) as boolean Dim Ret As QOCINFO Ret.dwSize = Len(Ret) testReseau= (IsDestinationReachable(Nom, Ret) <>0) End Sub
Utilisation :

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

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


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