mythic_kruger
Messages postés241Date d'inscriptionjeudi 8 janvier 2004StatutMembreDernière intervention10 novembre 2005
-
11 janv. 2005 à 02:37
soldier8514
Messages postés295Date d'inscriptionvendredi 20 décembre 2002StatutMembreDernière intervention24 janvier 2014
-
18 juin 2006 à 09:50
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
soldier8514
Messages postés295Date d'inscriptionvendredi 20 décembre 2002StatutMembreDernière intervention24 janvier 20141 18 juin 2006 à 09:50
lol avec cette solution le bouton ok de la boite de dialogue s'active dès qu'on clique sur n'importe quel dossier _ comment fairais tu SamDotNet pour que ça s'active seulement quand l'utilisateur clique sur le dossier "windows" ? ( un exemple au hazard ;)
fadelovesky
Messages postés38Date d'inscriptionsamedi 12 février 2005StatutMembreDernière intervention27 décembre 2008 11 sept. 2005 à 03:05
comment changer la caption de la boite de dialogue par ex à la place de "Rechercher un dossier" on peut mettre "vbfrance dossier"?
cs_CFCTABLE
Messages postés18Date d'inscriptionsamedi 1 mars 2003StatutMembreDernière intervention14 avril 2008 12 janv. 2005 à 22:17
merci à Serge Lachapelle. et à Samdotnet car je recherchais aussi depus un moment un code de ce genre.
Option Explicit
Public Const MAX_PATH = 260
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 Type SHITEMID
cb As Long
abID As Byte
End Type
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private m_CurrentDirectory As String
Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
End Function
Private Function BrowseCallbackProc(ByVal HWND As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Local Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
Select Case uMsg
Case BFFM_INITIALIZED
SendMessage HWND, BFFM_SETSELECTION, 1, m_CurrentDirectory
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)
ret = SHGetPathFromIDList(lp, sBuffer)
If ret = 1 Then
SendMessage HWND, BFFM_SETSTATUSTEXT, 0, sBuffer
End If
End Select
BrowseCallbackProc = 0
End Function
Public Function BrowseForFolder(Optional ByVal Title As String "", Optional ByVal RootDir As String "", Optional ByVal StartDir As String = "", Optional owner As Form = Nothing, Optional IncludeFiles As Boolean = False) As String
Const BIF_STATUSTEXT = &H4
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_BROWSEINCLUDEFILES = &H4000
Dim lpIDList As Long, lpIDList2 As Long, IDL As ITEMIDLIST
Dim sBuffer As String, tBrowseInfo As BrowseInfo, r As Long
If Len(RootDir) > 0 Then
If PathIsDirectory(RootDir) Then
SHParseDisplayName StrPtr(RootDir), ByVal 0&, lpIDList2, ByVal 0&, ByVal 0&
tBrowseInfo.pIDLRoot = lpIDList2
Else
r = SHGetSpecialFolderLocation(ByVal 0&, &H11, IDL)
If r 0 Then tBrowseInfo.pIDLRoot IDL.mkid.cb
End If
Else
r = SHGetSpecialFolderLocation(ByVal 0&, &H11, IDL)
If r 0 Then tBrowseInfo.pIDLRoot IDL.mkid.cb
End If
If Len(StartDir) > 0 Then
m_CurrentDirectory = StartDir & vbNullChar
Else
m_CurrentDirectory = vbNullChar
End If
If Len(Title) > 0 Then
tBrowseInfo.lpszTitle = lstrcat(Title, "")
Else
tBrowseInfo.lpszTitle = lstrcat("Select A Directory", "")
End If
tBrowseInfo.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
If IncludeFiles = True Then
tBrowseInfo.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS + BIF_BROWSEINCLUDEFILES
Else
tBrowseInfo.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS
End If
If Not (owner Is Nothing) Then tBrowseInfo.hWndOwner = owner.HWND
lpIDList = SHBrowseForFolder(tBrowseInfo)
If Len(RootDir) > 0 Then
If PathIsDirectory(RootDir) Then CoTaskMemFree lpIDList2
End If
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
CoTaskMemFree lpIDList
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
Else
BrowseForFolder = ""
End If
End Function
cs_Jack
Messages postés14006Date d'inscriptionsamedi 29 décembre 2001StatutModérateurDernière intervention28 août 201579 11 janv. 2005 à 18:19
Lu SamDotNet
-1- Si ce code est spécifique au Net (vu ton pseudo), n'oublie pas de cocher la case adéquat
-2- Le type BrowseInfo, lstrcat, MAX_PATH, CoTaskMemFree, BIF_RETURNONLYFSDIRS sont définis comment ?
Ca manque singulièrement de précisions ...
plaineR
Messages postés237Date d'inscriptionmercredi 26 novembre 2003StatutMembreDernière intervention 6 décembre 20054 11 janv. 2005 à 09:19
Il y a encore plus simple :
1. Dans référence, tu rajoutes Microsoft Shell Controls and Automation
2. Et voici le code à taper :
Dim oShell As Shell
Dim sPath As String
Set oShell = New Shell
On Error GoTo annule
sPath = oShell.BrowseForFolder(hWnd, "Choix répertoire", 1 Or 2.Items.item.path
Txtbox.Text = sPath 'la tu enregistres le path contenu dans sPath la ou tu veux
Set oShell = Nothing
Exit Sub
annule:
'l'annulation provoque une erreur
Exit Sub
Et le tours est joué !
mythic_kruger
Messages postés241Date d'inscriptionjeudi 8 janvier 2004StatutMembreDernière intervention10 novembre 2005 11 janv. 2005 à 02:37
Ce code est déjà sur le site. Justement j'y jetais un oeil dessus ce matin. Ca fonctionne bien. Une question, comment changer la taille de cette fenêtre? Elle est un peu petite.
18 juin 2006 à 09:50
11 sept. 2005 à 03:05
12 janv. 2005 à 22:17
merci à Serge Lachapelle. et à Samdotnet car je recherchais aussi depus un moment un code de ce genre.
Option Explicit
Public Const MAX_PATH = 260
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 Type SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
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 PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private m_CurrentDirectory As String
Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
End Function
Private Function BrowseCallbackProc(ByVal HWND As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Local Error Resume Next
Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String
Select Case uMsg
Case BFFM_INITIALIZED
SendMessage HWND, BFFM_SETSELECTION, 1, m_CurrentDirectory
Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)
ret = SHGetPathFromIDList(lp, sBuffer)
If ret = 1 Then
SendMessage HWND, BFFM_SETSTATUSTEXT, 0, sBuffer
End If
End Select
BrowseCallbackProc = 0
End Function
Public Function BrowseForFolder(Optional ByVal Title As String "", Optional ByVal RootDir As String "", Optional ByVal StartDir As String = "", Optional owner As Form = Nothing, Optional IncludeFiles As Boolean = False) As String
Const BIF_STATUSTEXT = &H4
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_BROWSEINCLUDEFILES = &H4000
Dim lpIDList As Long, lpIDList2 As Long, IDL As ITEMIDLIST
Dim sBuffer As String, tBrowseInfo As BrowseInfo, r As Long
If Len(RootDir) > 0 Then
If PathIsDirectory(RootDir) Then
SHParseDisplayName StrPtr(RootDir), ByVal 0&, lpIDList2, ByVal 0&, ByVal 0&
tBrowseInfo.pIDLRoot = lpIDList2
Else
r = SHGetSpecialFolderLocation(ByVal 0&, &H11, IDL)
If r 0 Then tBrowseInfo.pIDLRoot IDL.mkid.cb
End If
Else
r = SHGetSpecialFolderLocation(ByVal 0&, &H11, IDL)
If r 0 Then tBrowseInfo.pIDLRoot IDL.mkid.cb
End If
If Len(StartDir) > 0 Then
m_CurrentDirectory = StartDir & vbNullChar
Else
m_CurrentDirectory = vbNullChar
End If
If Len(Title) > 0 Then
tBrowseInfo.lpszTitle = lstrcat(Title, "")
Else
tBrowseInfo.lpszTitle = lstrcat("Select A Directory", "")
End If
tBrowseInfo.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
If IncludeFiles = True Then
tBrowseInfo.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS + BIF_BROWSEINCLUDEFILES
Else
tBrowseInfo.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS
End If
If Not (owner Is Nothing) Then tBrowseInfo.hWndOwner = owner.HWND
lpIDList = SHBrowseForFolder(tBrowseInfo)
If Len(RootDir) > 0 Then
If PathIsDirectory(RootDir) Then CoTaskMemFree lpIDList2
End If
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
CoTaskMemFree lpIDList
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
Else
BrowseForFolder = ""
End If
End Function
11 janv. 2005 à 18:19
-1- Si ce code est spécifique au Net (vu ton pseudo), n'oublie pas de cocher la case adéquat
-2- Le type BrowseInfo, lstrcat, MAX_PATH, CoTaskMemFree, BIF_RETURNONLYFSDIRS sont définis comment ?
Ca manque singulièrement de précisions ...
11 janv. 2005 à 09:19
1. Dans référence, tu rajoutes Microsoft Shell Controls and Automation
2. Et voici le code à taper :
Dim oShell As Shell
Dim sPath As String
Set oShell = New Shell
On Error GoTo annule
sPath = oShell.BrowseForFolder(hWnd, "Choix répertoire", 1 Or 2.Items.item.path
Txtbox.Text = sPath 'la tu enregistres le path contenu dans sPath la ou tu veux
Set oShell = Nothing
Exit Sub
annule:
'l'annulation provoque une erreur
Exit Sub
Et le tours est joué !
11 janv. 2005 à 02:37