1. With FileDialog Objet
1
2
3
4
5
6
7
| Sub Sample1()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
MsgBox .SelectedItems(1)
End If
End With
End Sub
|
2. With Shell
1
2
3
4
5
6
7
8
| Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "Please select a folder", &H1 + &H10, "C:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Sub
|
3. With Use API (methode1)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
| Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
| Function GetFolder(Optional Msg) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select folder..."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
If R Then
pos = InStr(pPath, Chr$(0))
GetFolder = Left(pPath, pos - 1)
Else
GetFolder = ""
End If
End Function
|
1
2
3
4
5
6
| Sub Sample3()
Dim buf As String
buf = GetFolder("Please select a folder")
If buf = "" Then Exit Sub
MsgBox buf
End Sub
|
4. With Use API (methode2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
| Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As String
iImage As Long
End Type
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
| Function GetDirectory(Optional Msg, Optional UserPath) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
With bInfo
.pidlRoot = &H0
If IsMissing(Msg) Then
.lpszTitle = "Select a folder..."
Else
.lpszTitle = Msg
End If
.ulFlags = &H40
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
If IsMissing(UserPath) Then
.lParam = CurDir & Chr(0)
Else
.lParam = UserPath & Chr(0)
End If
End With
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
CoTaskMemFree X
If R Then
pos = InStr(pPath, Chr(0))
GetDirectory = Left(pPath, pos - 1)
Else
GetDirectory = ""
End If
End Function
|
1
2
3
4
5
6
| Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
lParam As Long, ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSELECTIONA, 1, ByVal lpData
End If
End Function
|
1
2
3
| Public Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function
|
1
2
3
4
5
6
7
8
9
| Sub Sample4()
Dim buf As String
buf = GetDirectory("Please select a folder", "C:\")
If buf = "" Then
Exit Sub
Else
MsgBox buf
End If
End Sub
|
Download
File
Download
File (64bit support)
No comments :
Post a Comment