| |
Ce code permet d'afficher la fenêtre "Arrêter l'ordinateur" de Windows
Private Declare Function SHShutDownDialog Lib _
"shell32" Alias "#60" (ByVal YourGuess As Long) As Long
Private Sub Arreter()
SHShutDownDialog 0
End Sub |
|
| | Versions : 97 et supérieures
Ce code permet d'afficher la fenêtre Exécuter du menu démarrer. Cela peut être utile pour permettre à l'utilisateur de selectionner un programme à lancer. Le lancement se fait automatiquement par la fenêtre Exécuter. Ceci évite d'avoir à coder l'ouverture du fichier.
Dans un module, placez le code suivant :
Const shrdNoMRUString = &H2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias _
"GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function SHRunDialog Lib "shell32" Alias "#61" _
(ByVal hOwner As Long, ByVal Unknown1 As Long, ByVal Unknown2 As _
Long, ByVal szTitle As String, ByVal szPrompt As String, _
ByVal uFlags As Long) As Long
Function WindowsNT() As Boolean
Dim Info As OSVERSIONINFO
Dim Result As Integer
Info.dwOSVersionInfoSize = Len(Info)
Result = GetVersionEx(Info)
WindowsNT = (Info.dwPlatformId = 2)
End Function
Public Sub AfficherExecuter()
Dim Titre As String, Message As String
Titre = "Lancer un programme"
Message = "Tapez le nom d'un programme ou bien " & _
"utilisez le bouton parcourir"
If WindowsNT Then
SHRunDialog 0, 0, 0, StrConv(Titre, vbUnicode), _
StrConv(Message, vbUnicode), 0
Else
SHRunDialog 0, 0, 0, Titre, Message, 0
End If
End Sub |
Le passage de paramètre n'étant pas le même pour les différentes versions de Windows, la fonction WindowsNT permet de savoir sur quelle plateforme est utilisée l'application.
|
| | Versions : 2000 et supérieures
Voici un moyen de permettre à l'utilisateur de sélectionner une police. Cet exemple utilise l'API Windows ChooseFont qui affiche la boîte de dialogue commune Windows intitulée Sélectionner une police.
Dans un module :
Public Type Police
Nom As String
Taille As Long
Souligne As Boolean
Italique As Boolean
Gras As Boolean
Barre As Boolean
Couleur As Long
End Type
Const LOGPIXELSY = 90
Const FW_NORMAL = 400
Const FW_GRAS = 700
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const CF_NOSCRIPTSEL = &H800000
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 31
End Type
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" _
Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) 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
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Public Function ChoisirPolice(Handle As Long, _
PoliceParDefaut As Police) As Police
Dim Boite As CHOOSEFONT, LaPolice As LOGFONT, _
hMem As Long, pMem As Long
Dim resultat As Long, Retour As Police
LaPolice.lfStrikeOut = PoliceParDefaut.Barre
LaPolice.lfWeight = IIf(PoliceParDefaut.Gras, _
FW_GRAS, FW_NORMAL)
LaPolice.lfItalic = PoliceParDefaut.Italique
LaPolice.lfUnderline = PoliceParDefaut.Souligne
LaPolice.lfHeight = -PoliceParDefaut.Taille * _
GetDeviceCaps(GetDC(Handle), LOGPIXELSY) / 72
If PoliceParDefaut.Nom = "" Then _
PoliceParDefaut.Nom = "Tahoma"
LaPolice.lfFaceName = PoliceParDefaut.Nom & _
vbNullChar
hMem = GlobalAlloc(GMEM_MOVEABLE _
Or GMEM_ZEROINIT, Len(LaPolice))
pMem = GlobalLock(hMem)
CopyMemory ByVal pMem, LaPolice, Len(LaPolice)
Boite.lStructSize = Len(Boite)
Boite.hwndOwner = Handle
Boite.lpLogFont = pMem
Boite.iPointSize = 120
Boite.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or _
CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE Or _
CF_NOSCRIPTSEL
Boite.rgbColors = PoliceParDefaut.Couleur
Boite.nFontType = REGULAR_FONTTYPE
Boite.nSizeMin = 6
Boite.nSizeMax = 72
resultat = CHOOSEFONT(Boite)
If resultat <> 0 Then
CopyMemory LaPolice, ByVal pMem, Len(LaPolice)
Retour.Nom = Left(LaPolice.lfFaceName, _
InStr(LaPolice.lfFaceName, vbNullChar) - 1)
Retour.Taille = Boite.iPointSize \ 10
Retour.Couleur = Boite.rgbColors
Retour.Gras = LaPolice.lfWeight > FW_NORMAL
Retour.Italique = LaPolice.lfItalic
Retour.Souligne = LaPolice.lfUnderline
Retour.Barre = LaPolice.lfStrikeOut
End If
resultat = GlobalUnlock(hMem)
resultat = GlobalFree(hMem)
ChoisirPolice = Retour
End Function |
Puis pour changer la police d'un contrôle, appliquer le code suivant sur un bouton :
Dim P As Police
With P
.Barre = False
.Couleur = Lbl_Texte.ForeColor
.Gras = Lbl_Texte.FontBold
.Italique = Lbl_Texte.FontItalic
.Souligne = Lbl_Texte.FontUnderline
.Taille = Lbl_Texte.FontSize
.Nom = Lbl_Texte.fontname
End With
P = ChoisirPolice(Me.Hwnd, P)
With Lbl_Texte
If P.Taille <> 0 Then
.ForeColor = P.Couleur
.FontBold = P.Gras
.FontItalic = P.Italique
.fontname = P.Nom
.FontUnderline = P.Souligne
.FontSize = P.Taille
End If
End With |
Le principe est simple, il suffit de créer un type Police contenant les informations actuelles du contrôle puis d'appeler la boîte de dialogue avec cette police par défaut. Enfin, il faut appliquer le résultat reçu de la boîte de dialogue au contrôle en question.
Pour plus d'informations, n'hésitez pas à télecharger le fichier source zippé.
|
| |
Ce petit exemple est destiné à vous permettre d'afficher la boite de dialogue A propos dans votre application. Cela peut représenter un petit plus dans la personnalisation de votre application et vous permettra par exemple d'afficher la version, etc...
Voici le code :
Private Declare Function ShellAbout Lib "shell32.dll" Alias _
"ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, _
ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Sub AfficherApropos_Click()
Dim Titre As String, Message As String
Titre = "Sources Access"
Message = "Ceci est un exemple de developpez.com sur l'utilisation des API"
ShellAbout me.hwnd, Titre, Message, VICon
End Sub |
|
| | Versions : 2000 et supérieures
Ce code permet de sélectionner une ressource ActiveDirectory.
Placer dans un module :
Private Const MAX_PATH = 160
Private Type DSBROWSEINFO
cbStruct As Long
hwndOwner As Long
pszCaption As String
pszTitle As String
pszRoot As String
pszPath As Long
cchPath As Long
dwFlags As Long
pfnCallback As Long
lParam As Long
dwReturnFormat As Long
pUserName As String
pPassword As String
pszObjectClass As String
cchObjectClass As Long
End Type
Private Declare Function DsBrowseForContainer Lib "dsuiext" Alias _
"DsBrowseForContainerA" (pInfo As DSBROWSEINFO) As Long
Public Function ActiveDirectory() as string
Dim dsbi As DSBROWSEINFO, szResult As String
szResult = Space(MAX_PATH)
dsbi.cbStruct = Len(dsbi)
dsbi.pszCaption = "Active Directory"
dsbi.pszTitle = "Choisir une ressource"
dsbi.pszPath = StrPtr(szResult)
dsbi.cchPath = Len(szResult)
DsBrowseForContainer dsbi
ActiveDirectory=szResult
End Function |
Utilisation : Ceci affiche le nom de la ressource sélectionnée.
|
| | Versions : 97 et supérieures
Ce code utilise les API Windows, afin d'afficher une palette de couleur Windows.
Dans un module, placer le code suivant :
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias _
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function ShowColor(Handle As Long) As Long
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As Long
Dim lReturn As Long
cc.lStructSize = Len(cc)
cc.hwndOwner = Handle
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
If CHOOSECOLOR(cc) <> 0 Then
ShowColor = cc.rgbResult
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
ShowColor = -1
End If
End Function |
Puis, sur l'évênement Clic d'un bouton, placer le code suivant : Dim lacouleur as long
lacouleur=ShowColor(Me.hwnd) |
Si l'utilisateur choisit une couleur, alors la variable lacouleur a pour valeur le code de cette couleur. Sinon, elle vaut -1 (cas où l'utilisateur clique sur Annuler).
|
| | Versions : 97 et supérieures
Ce code permet d'afficher une boite de télechargement pour proposer à l'utilisateur d'enregistrer un fichier et de suivre l'état de la copie à l'aide d'une barre de progression.
L'API utiliser peut recevoir soit le nom d'un fichier en local ou une url voire même un chemin réseau.
Private Declare Function DoFileDownload Lib "shdocvw.dll" _
(ByVal lpszFile As String) As Long
Public Sub TelechargerFichier(Fichier as string)
DoFileDownload StrConv(Fichier, vbUnicode)
End Sub |
Utilisation :
TelechargerFichier("d:\test.mdb")
TelechargerFichier(""http://www.monsite.fr/monfichier.zip") |
|
| | Versions : 97 et supérieures
L'utilisation de l'API Windows pour afficher une boite de dialogue est plus rapide et plus économe en ressource que celle de la fonction VB Msgbox.
Dans un module :
Const MB_DEFBUTTON1 = &H0&
Const MB_DEFBUTTON2 = &H100&
Const MB_DEFBUTTON3 = &H200&
Const MB_ICONASTERISK = &H40&
Const MB_ICONEXCLAMATION = &H30&
Const MB_ICONHAND = &H10&
Const MB_ICONINFORMATION = MB_ICONASTERISK
Const MB_ICONQUESTION = &H20&
Const MB_ICONSTOP = MB_ICONHAND
Const MB_OK = &H0&
Const MB_OKCANCEL = &H1&
Const MB_YESNO = &H4&
Const MB_YESNOCANCEL = &H3&
Const MB_ABORTRETRYIGNORE = &H2&
Const MB_RETRYCANCEL = &H5&
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" _
(ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, _
ByVal wType As Long) As Long |
Utilisation : Dim reponse as long
reponse=MessageBox(me.Hwnd, "Voulez vous continuer", _
"Demande de confirmation", MB_YESNO + MB_ICONQUESTION))
If reponse=VbYes then
End if |
|
| |
Ce code permet d'afficher un message demandant à l'utilisateur de redémarrer son ordinateur. S'il clique sur oui, le redémarrage se fera automatiquement.
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Private Declare Function SHRestartSystemMB Lib "shell32" _
Alias "#59" (ByVal hOwner As Long, ByVal sExtraPrompt As String, _
ByVal uFlags As Long) As Long
Private Sub AfficherRedemarrer()
SHRestartSystemMB 0, vbNullString, EWX_REBOOT
End Sub |
|
|