Soyez le premier à donner votre avis sur cette source.
Snippet vu 7 953 fois - Téléchargée 41 fois
'================================== ' Code trouve sur le site : ' http://www.c2i.fr/code.asp?IDCode=1083 '================================== 'a mettre dans un module : '================================== 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_SETSTATUSTEXT = (WM_USER + 100) Private Const BFFM_SETSELECTION = (WM_USER + 102) 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 Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long 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 Private m_CurrentDirectory As String 'The current directory Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String 'ouvre la boite de dialogue sélectionnant un dossier Dim lpIDList As Long Dim szTitle As String Dim sBuffer As String Dim tBrowseInfo As BrowseInfo m_CurrentDirectory = StartDir & vbNullChar szTitle = Title With tBrowseInfo .hWndOwner = owner.hWnd .lpszTitle = lstrcat(szTitle, "") .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function. End With lpIDList = SHBrowseForFolder(tBrowseInfo) If (lpIDList) Then sBuffer = Space(MAX_PATH) SHGetPathFromIDList lpIDList, sBuffer sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) BrowseForFolder = sBuffer Else BrowseForFolder = "" End If End Function Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long Dim lpIDList 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, m_CurrentDirectory) Case BFFM_SELCHANGED sBuffer = Space(MAX_PATH) ret = SHGetPathFromIDList(lp, 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 GetAddressofFunction(add As Long) As Long GetAddressofFunction = add End Function '===================================== 'exemple d'utilisation, dans une procedure '===================================== Dim rep as String rep = BrowseForFolder(Me, "Un texte", "c:\windows\")
24 sept. 2008 à 14:02
19 avril 2007 à 00:16
18 avril 2007 à 19:08
18 avril 2007 à 17:33
17 avril 2007 à 23:53
Pour l'utiliser, un p'tit coup de recherche sur VBFrance. Il y a tellement de sources et de messages qui en parlent ...
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.