Les mémos

Fermer Tables

Fermer Requêtes

Fermer Formulaires

Fermer Etats

Fermer Modules

Fermer Base

Fermer Automation

Fermer Administration

Fermer Registre

Fermer String

Fermer Email CDO

Fermer Outlook

Fermer Net

Fermer Dates - Heures

Fermer Fichiers

Fermer Références

Fermer Vrac

Je débute...

Fermer La normalisation

Fermer VBA

Attention
Aucun support
par émail !

Utilisez le forum pour les questions/réponses concernant MsAccess et les codes que vous trouverez sur ce site.
Visites

   visiteurs

   visiteurs en ligne

Fichiers - Sélection de dossier (API)

Parcourir et sélectionner un dossier - bis (API)

Retourne le nom du dossier sélectionné, mais permet en plus de renseigner un chemin par défaut
Usage :
Dim ChoixDossier As String
ChoixDossier = fn_RechDossier(Me.Hwnd, "Message", "D:/DossierSelectionné") 
 
Option Compare Database
Option Explicit
'//--- DECLARATION DES API 's ---
'//
   Private Declare Function SHBrowseForFolder Lib "shell32" _
      (lpbi As BrowseInfo) As Long
   '// Dossier séléctionner.
   Private Declare Function SHGetPathFromIDList Lib "shell32" _
      (ByVal pidList As Long, ByVal lpBuffer As String) As Long

   '// Pointeur du buffer.
   Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
      (ByVal lpString1 As String, ByVal lpString2 As String) As Long

   '// Envoie d'un message, à windows(destiné à la boite).
   Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
      (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
       ByVal lParam As String) As Long

   '// Positionnement de la boite.
   Private 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

   Private Const BIF_STATUSTEXT = &H4&
   Private Const BIF_RETURNONLYFSDIRS = 1
   Private Const BIF_DONTGOBELOWDOMAIN = 2
   Private Const MAX_PATH = 260
   Private Const WM_USER = &H400
   Private Const BFFM_INITIALIZED = 1
   Private Const BFFM_SELCHANGED = 2
   Private Const BFFM_SETSELECTION = (WM_USER + 102)
   Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)

   Private Type BrowseInfo
      hWndOwner      As Long
      pIDLRoot       As Long
      pszDisplayName As Long
      lpszTitle      As Long
      ulFlags        As Long
      lpfnCallback   As Long
      lParam         As Long
      iImage         As Long
   End Type
'//--- DECLARATION DES VARIABLES ----
'//
'// Dossier sélectionner dans la boite SelDos.
    Private msDosCour As String
'//
Public Function fn_RechDossier _
   (hndF As Long, sTitre As String, sDosDep As String) As String
'// --------------------------­------------------------------­-----
'// Création :
'// Objectif :
'//     Affiche une boite de dialogue équivalent au volet d'exploration
'//     'Dossiers' de l'Explorateur. Elle permet d'obtenir le nom et le
'//     chemin d'un répertoire choisi par l'utilisateur.
'//     La sélection que d'une unité (C:) est possible.
'//
'// ---> ENTRE
'//      hndF    : Handler de la fenêtre qui appele la boite.
'//      sTitre  : titre de la boite.
'//      sDosDep : Dossier sélectionné à l'ouverture.
'//
'// <--- SORT
'//       Chemin et nom du répertoire sélectionné.
'// ------------------------------­------------------------------­-----

   Dim lpIDList   As Long
   Dim szTitle    As String
   Dim sBuffer    As String
   Dim tBrowseInf As BrowseInfo

   msDosCour = sDosDep & vbNullChar
   szTitle = sTitre

   With tBrowseInf
      .hWndOwner = hndF
      .lpszTitle = lstrcat(szTitle, "")
      .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT
      .lpfnCallback = fn_ObtenirAdrOf(AddressOf BrowseCallbackProc)
   End With

   '// voir si l'utilisateur à sélectionné qq chose
   lpIDList = SHBrowseForFolder(tBrowseInf)

   If (lpIDList) Then
      '// format et renvoie le chemin complet du dossier choisi.
      sBuffer = Space(MAX_PATH)
      SHGetPathFromIDList lpIDList, sBuffer
      sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
      fn_RechDossier = sBuffer
   Else
      fn_RechDossier = ""
   End If
End Function
Private Function BrowseCallbackProc _
   (ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal lParam As Long, _
    ByVal lpData As Long) As Long
   Const SWP_NOSIZE   As Long = 1
   Const SWP_NOZORDER As Long = 4
   Const XCoor        As Long = 150   '// in Pixeln
   Const YCoor        As Long = 250   '// in Pixeln
   Dim L          As Long
   Dim ret        As Long
   Dim sBuffer    As String
On Error Resume Next '// Sugested by MS to prevent an error from
                     '// propagating back into the calling process.
   Select Case uMsg
      Case BFFM_INITIALIZED
        Call SendMessage(hwnd, BFFM_SETSELECTION, 1, msDosCour)
        L = SetWindowPos(hwnd, 0&, XCoor, YCoor, 0&, 0&, SWP_NOSIZE Or SWP_NOZORDER)
    Case BFFM_SELCHANGED
        sBuffer = Space(MAX_PATH)
        ret = SHGetPathFromIDList(lParam, sBuffer)
        If ret = 1 Then
            Call SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
        End If
   End Select
   BrowseCallbackProc = 0
End Function
'// This function allows you to assign a function pointer to a vaiable.
Private Function fn_ObtenirAdrOf(add As Long) As Long
   fn_ObtenirAdrOf = add
End Function

Date de création : 02/11/2005 : 00:27
Dernière modification : 08/02/2010 : 02:10
Catégorie : Fichiers
Page lue 5076 fois


Imprimer l'article Imprimer l'article

Recherche



Lettre d'information
Pour avoir des nouvelles de ce site, inscrivez-vous à notre Newsletter.
Captcha
Recopier le code :
Au sujet de l'auteur
L'auteur qui fréquente (fréquentait) le forum microsoft.public.fr.access a eu le plaisir d'être nommé MVP Office-Access de janvier 2003 à décembre 2011.

Qui sont les MVP ?

Divers ;-)
Nous contacter

Haut