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



Auteur : Tofalu
Version : 05/02/2005
Page de l'auteur
Afficher la fenêtre Arreter l'ordinateur
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

Auteur : Tofalu
Version : 05/02/2005
Page de l'auteur
Afficher la fenêtre Exécuter
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) 'Récupere la version de Windows 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" 'Si windows NT, alors utiliser unicode If WindowsNT Then SHRunDialog 0, 0, 0, StrConv(Titre, vbUnicode), _ StrConv(Message, vbUnicode), 0 'sinon, utiliser un string normal 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.


Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur
Téléchargez le zip
Afficher la boîte de dialogue de selection de police
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 '***************************************** 'definit la police par defaut à afficher 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 'Nom de la police par defaut '****************************************** ' Creer une structure LOGFont en memoire. hMem = GlobalAlloc(GMEM_MOVEABLE _ Or GMEM_ZEROINIT, Len(LaPolice)) 'Verouille et recupere le pointeur vers la structure pMem = GlobalLock(hMem) 'Copie la structure CopyMemory ByVal pMem, LaPolice, Len(LaPolice) 'Initialise la boite de dialogue Boite.lStructSize = Len(Boite) Boite.hwndOwner = Handle 'Affecte la police par defaut Boite.lpLogFont = pMem 'defini la taille (10*La taille de la police) Boite.iPointSize = 120 'PoliceParDefaut.Taille * 10 'Personalise la boite Boite.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or _ CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE Or _ CF_NOSCRIPTSEL 'Fixe la couleur Boite.rgbColors = PoliceParDefaut.Couleur Boite.nFontType = REGULAR_FONTTYPE 'Definit les tailles possibles Boite.nSizeMin = 6 Boite.nSizeMax = 72 'Ouvre la boite resultat = CHOOSEFONT(Boite) If resultat <> 0 Then CopyMemory LaPolice, ByVal pMem, Len(LaPolice) 'Prepare le resultat Retour.Nom = Left(LaPolice.lfFaceName, _ InStr(LaPolice.lfFaceName, vbNullChar) - 1) Retour.Taille = Boite.iPointSize \ 10 Retour.Couleur = Boite.rgbColors 'La police est en gras lorsque largeur n'est pas normale Retour.Gras = LaPolice.lfWeight > FW_NORMAL Retour.Italique = LaPolice.lfItalic Retour.Souligne = LaPolice.lfUnderline Retour.Barre = LaPolice.lfStrikeOut End If 'Libère la mémoire 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 'Recupere la police actuelle 'pour alimenter les valeurs par 'défaut de la boîte de dialogue 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 'Affiche la boite de dialogue P = ChoisirPolice(Me.Hwnd, P) 'Applique la nouvelle valeur au controle With Lbl_Texte 'si taille=0 alors signife annuler 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é.


Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur
Afficher la boite de dialogue A propos
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 :

'Declaration de l'API 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 'Procedure sur le clique d'un bouton 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

Auteur : Tofalu
Version : 05/03/2005
Page de l'auteur
Afficher une boite de dialogue ActiveDirectory
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() 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) 'Appel de la fonction DsBrowseForContainer dsbi 'Renvoit le résultat ActiveDirectory=szResult End Function
Utilisation :

Msgbox ActiveDirectory()
Ceci affiche le nom de la ressource sélectionnée.


Auteur : Tofalu
Version : 04/02/2005
Page de l'auteur
Afficher une boite de dialogue de sélection de couleur
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 'set the structure size cc.lStructSize = Len(cc) 'Set the owner cc.hwndOwner = Handle 'set the custom colors (converted to Unicode) cc.lpCustColors = StrConv(CustomColors, vbUnicode) 'no extra flags cc.flags = 0 'Show the 'Select Color'-dialog 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).


Auteur : Tofalu
Version : 04/02/2005
Page de l'auteur
Afficher une fenêtre de télechargement pour copier un fichier
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.

'Déclaration de l'API 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")

Auteur : Tofalu
Version : 04/02/2005
Page de l'auteur
Afficher une msgbox avec l'API Windows
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 '.......... 'code à effectuer si l'utilisateur clique sur Oui End if

Auteur : Tofalu
Version : 05/02/2005
Page de l'auteur
Inviter l'utilisateur à redémarrer son ordinateur
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


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.