| | 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" |
|
| | 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 |
|
| | 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 | | |
| |
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
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type TaskBarInformation
Left As Long
Top As Long
Width As Long
Height As Long
Position As Long
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
intI = GetDeviceCaps(GetDC(0), 8) \ 2
intJ = GetDeviceCaps(GetDC(0), 10) \ 2
hwnd = FindWindow("Shell_traywnd", "")
GetWindowRect hwnd, rctTemp
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 |
|
| |
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
|
| | 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
|
| | 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
Buffer = MAX_COMPUTERNAME_LENGTH + 1
Reponse = String(Buffer, " ")
GetComputerName Reponse, Buffer
Reponse = Left(Reponse, Buffer)
NomMachine = Reponse
err:
End Function |
Utilisation :
Afficher le nom de la machine : Changer le nom de la machine : ChangerNomMachine ("mamachine") |
|
| | 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
CurrentDb.Execute ("DELETE FROM Tbl_Process")
SnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
ProcessEnt.dwSize = Len(ProcessEnt)
Proc = Process32First(SnapShot, ProcessEnt)
While Proc
With ProcessEnt
SQL = "Insert Into Tbl_Process VALUES (" & _
.th32ProcessID & "," & Chr(34) & StrZToStr(.szExeFile) & Chr(34) & _
"," & .cntThreads & ")"
End With
CurrentDb.Execute SQL
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.
|
| |
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 :
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()
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)
strAttributes = strAttributes & "DESCRIPTION=Test DSN par VBA" & Chr$(0)
strAttributes = strAttributes & "DBQ=" & "C:\bd1.mdb" & Chr$(0)
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()
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)
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()
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)
Call SQLConfigDataSource(Me.hWnd, ODBC_CONFIG_DSN, strDriver, strAttributes)
End Sub |
|
| |
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)
Dim lngAppPID As Long
Dim lngWindowHandle As Long
lngAppPID = Shell(ApplicationPath, IIf(IsVisible, SW_SHOWNORMAL, SW_HIDE))
DoEvents
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
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
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...
|
| |
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
lngHauteur = GetDeviceCaps(lngHdc, 10)
lngLargeur = GetDeviceCaps(lngHdc, 8)
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
If BitBlt(lngHdc, 0&, 0&, lngLargeur, lngHauteur, _
GetDC(GetDesktopWindow()), 0&, 0&, SRCCOPY) = 0 Then
GoTo Finally
End If
With bmfBitmapFileHeader
.bfType = &H4D42&
.bfOffBits = Len(bmfBitmapFileHeader) + Len(bmiBitmapInfo)
.bfSize = .bfOffBits + bmiBitmapInfo.biSizeImage
End With
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
Open strNomDuFichier For Binary As lngFnum
bolOuvert = True
Put #lngFnum, , bmfBitmapFileHeader
Put #lngFnum, , bmiBitmapInfo
Put #lngFnum, , pixels
Finally:
If bolOuvert Then Close lngFnum
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 | | |
| | 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 | | |
| | 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 |
|
|