Private Declare Function SHShutDownDialog Lib _
"shell32" Alias "#60" (ByVal YourGuess As Long) As Long
Private Sub Arreter()
    SHShutDownDialog 0
End Sub

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

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

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

'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

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

Msgbox ActiveDirectory()

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

Dim lacouleur as long
lacouleur=ShowColor(Me.hwnd)

'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

TelechargerFichier("d:\test.mdb")
TelechargerFichier(""http://www.monsite.fr/monfichier.zip")

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

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

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