Oliv-

Bonjour,
Voici plusieurs méthodes pour ouvrir une boite de dialogue et choisir un DOSSIER, à partir d'OUTLOOK (testé sous OL2010)


En utilisant EXCEL

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
 
Sub test()
Msgbox BrowseFolderExplorer("Choisissez un dossier", msoFileDialogViewDetails, SDossier(0, 0))
End Sub
 
 
Function BrowseFolderExplorer(Optional DialogTitle As String, _
                              Optional ViewType As MsoFileDialogView = _
                              MsoFileDialogView.msoFileDialogViewSmallIcons, _
                              Optional InitialDirectory As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim fDialog As Office.FileDialog
    Dim varFile As Variant
    Dim ExcelApp
    Set ExcelApp = CreateObject("Excel.application")
    ExcelApp.Visible = False
 
'pour mettre la boite de dialogue au premier plan
call ActiveExcel(ExcelApp.hwnd)
 
    'ExcelApp.WindowState = -4140
 
    Set fDialog = ExcelApp.FileDialog(msoFileDialogFolderPicker)
    fDialog.InitialView = ViewType
    With fDialog
        If DIR(InitialDirectory, vbDirectory) <> vbNullString Then
            .InitialFileName = InitialDirectory
        Else
            .InitialFileName = CurDir
        End If
        .Title = DialogTitle
 
        If .Show = True Then
            ' user picked a folder
            BrowseFolderExplorer = .SelectedItems(1)
        Else
            ' user cancelled
            BrowseFolderExplorer = vbNullString
        End If
    End With
    ExcelApp.Quit
End Function

Fonctions nécessaires à mettre dans un module

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
 
'====================dans un module standard
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Declare Function SetForegroundWindow Lib "user32" _
    (ByVal hwnd As Long) As Long
Declare Function ShowWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
 
 
' ShowWindow() Commands
Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_NORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_MAXIMIZE = 3
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_RESTORE = 9
Public Const SW_SHOWDEFAULT = 10
Public Const SW_MAX = 10
 
Public Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) As Long
 
'POUR ACTIVER EXCEL 
Sub ActiveExcel(hwnd As Long)
   If hwnd = 0 Then Exit Sub
  SetForegroundWindow hwnd
  ShowWindow hwnd, SW_SHOWMAXIMIZED
End Sub
 
'POUR CHOISIR UN DOSSIER SPECIAL
Public Function SDossier(dossier As Long, hwnd As Long)
    Dim buff As String
    buff = Space(260)
    SHGetSpecialFolderPath hwnd, buff, dossier, 0
    SDossier = Left(buff, InStr(1, buff, Chr(0)) - 1)
End Function
 
''''''Function SDossier ''''Constantes dossier'''''''''''''''''''''''''''''''''
 
'0=C:\Documents and Settings\USER\Bureau
'1=
'2=C:\Documents and Settings\USER\Menu Démarrer\Programmes
'3=
'4=
'5=C:\Documents and Settings\USER\Mes documents
'6=C:\Documents and Settings\USER\Favoris
'7=C:\Documents and Settings\USER\Menu Démarrer\Programmes\Démarrage
'8=C:\Documents and Settings\USER\Recent
'9=C:\Documents and Settings\USER\SendTo
'10=
'11=C:\Documents and Settings\USER\Menu Démarrer
'12=
'13=C:\Documents and Settings\USER\Mes documents\Ma musique
'14=C:\Documents and Settings\USER\Mes documents\Mes vidéos
'15=
'16=C:\Documents and Settings\USER\Bureau
'17=
'18=
'19=C:\Documents and Settings\USER\Voisinage réseau
'20=C:\WINDOWS\Fonts
'21=C:\Documents and Settings\USER\Modèles
'22=C:\Documents and Settings\All Users\Menu Démarrer
'23=C:\Documents and Settings\All Users\Menu Démarrer\Programmes
'24=C:\Documents and Settings\All Users\Menu Démarrer\Programmes\Démarrage
'25=C:\Documents and Settings\All Users\Bureau
'26=C:\Documents and Settings\USER\Application Data
'27=C:\Documents and Settings\USER\Voisinage d'impression
'28=C:\Documents and Settings\USER\Local Settings\Application Data
'29=
'30=
'31=C:\Documents and Settings\All Users\Favoris
'32=C:\Temporary Internet Files
'33=C:\Documents and Settings\USER\Cookies
'34=C:\Documents and Settings\USER\Local Settings\Historique
'35=C:\Documents and Settings\All Users\Application Data
'36=C:\WINDOWS
'37=C:\WINDOWS\system32
'38=C:\Program Files
'39=C:\Documents and Settings\USER\Mes documents\Mes images
'40=C:\Documents and Settings\USER
'41=C:\WINDOWS\system32
'42=
'43=C:\Program Files\Fichiers communs
'44=
'45=C:\Documents and Settings\All Users\Modèles
'46=C:\Documents and Settings\All Users\Documents
'47=C:\Documents and Settings\All Users\Menu Démarrer\Programmes\Outils d'administration
'48=C:\Documents and Settings\USER\Menu Démarrer\Programmes\Outils d'administration
'49=
'50=
'51=
'52=
'53=C:\Documents and Settings\All Users\Documents\Ma musique
'54=C:\Documents and Settings\All Users\Documents\Mes images
'55=C:\Documents and Settings\All Users\Documents\Mes vidéos
'56=C:\WINDOWS\resources
'57=
'58=
'59=C:\Documents and Settings\USER\Local Settings\Application Data\Microsoft\CD Burning
'60=

En utilisant le SHELL

Code VB :

Sélectionner tout - Visualiser dans une fenêtre à part

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
30
31
Function BrowseForWindowsFolder(Optional OpenAt As Variant) As Variant
'---------------------------------------------------------------------------------------
' Procedure : BrowseForWindowsFolder
' Author    : Diane Poremsky
' Date      : 23/07/2019
' Purpose   : https://www.slipstick.com/developer/code-samples/windows-filepaths-macro/
'---------------------------------------------------------------------------------------
'
 
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
            BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
    On Error Resume Next
    BrowseForWindowsFolder = ShellApp.self.Path
    On Error GoTo 0
 
    Set ShellApp = Nothing
    Select Case Mid(BrowseForWindowsFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForWindowsFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForWindowsFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
    Exit Function
 
Invalid:
    BrowseForWindowsFolder = False
End Function

en utilisant une API

Code VB :

Sélectionner tout - Visualiser dans une fenêtre à part

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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
'==================================
' 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
Public Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) 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
 
 
Sub test_BrowseForFolder()
  MsgBox BrowseForFolder("Un texte", SDossier(5, 0))
End Sub
Public Function BrowseForFolder(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
 
 
Public Function SDossier(Dossier As Long, hwnd As Long)
    Dim buff As String
    buff = Space(260)
    SHGetSpecialFolderPath hwnd, buff, Dossier, 0
    SDossier = Left(buff, InStr(1, buff, Chr(0)) - 1)
End Function

En utilisant MSHTA

Code vb :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
 
Sub test_GetFileNameDlg()
    Dim FichierPath As String
    Dim DossierPath As String
    FichierPath = GetFileNameDlg
    MsgBox FichierPath
 
    'Pour ne garder que le dossier
    'il faut donc au moins un fichier dans le dossier pour pouvoir le selectionner.
    Position = VBA.InStrRev(FichierPath, "\")
    DossierPath = Left(FichierPath, Position)
    MsgBox DossierPath
 
 
' autre methode OUVRIR
Function GetFileNameDlg()
'LONG
    GetFileNameDlg = CreateObject("WScript.Shell").Exec("mshta.exe ""about:<input type=file id=f><script language=""VBScript"">f.click():CreateObject(""Scripting.FileSystemObject"").GetStandardStream(1).WriteLine(f.value):close()</script>""").StdOut.ReadAll
End Function