Discussion :

[marycaLou]

Bonjour,

Dans une discussion précédente, je demandais de l'aide pour une macro qui permet d'enregistrer des courriels dans un dossier à partir de raccourci.

Avec votre aide, j'ai réussi mais j'aimerais savoir comment modifier mon code pour suggérer automatiquement le "bureau" d'un utilisateur.
Voici mon code :

Code :

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
 
...
    Function BrowseFolderExplorer(Optional DialogTitle As String, _
    Optional ViewType As MsoFileDialogView = _
        MsoFileDialogView.msoFileDialogViewSmallIcons, _
    Optional InitialDirectory As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BrowseFolderExplorer
' This provides an Explorer-like Folder Open dialog.
' http://www.cpearson.com/excel/browsefolder.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim fDialog  As Office.FileDialog
    Dim varFile As Variant
    Dim ExcelApp
    Set ExcelApp = CreateObject("Excel.application")
    ExcelApp.Visible = False
 
  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
  ....

Je sais qu'il faudrait changer la ligne 22 où il est question d'affecter ".InitialFileName ".
Mais comment repérer le nom du bureau d'un utilisateur. Surtout que plusieurs utilisateurs sur différents ordis utilisent la macro.

Merci

[Oliv-]

Bonjour,
Voici une foonction qui te donnera surement satisfaction :

Code :

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
 
Option Explicit
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
 
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
 
Sub Ou_est_le_bureau()
MsgBox SDossier(0, 0), vbOKOnly, "Chemin du bureau"
End Sub
 
 
Sub Lister_tous_dossiers_speciaux()
Dim i As Long
For i = 0 To 60
Debug.Print i & "=" & SDossier(i, 0)
Next i
End Sub

Ce n'est pas la ligne 22 qu'il faut modifier puisque cette fonction te demande justement dans ses parametres le dossier par defaut.

donc c'est l'appel à la fonction que tu dois modifier

Code :

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

1
2
3
 
 
toto= BrowseFolderExplorer("mon titre",null ,  SDossier(0, 0)      )

[marycaLou]

Bonjour,

J'ai modifié mon code pour faire afficher le contenu du bureau. Sauf que le résultat n'est pas tout à fait adéquat.

Lorsque j'active la macro, elle va dans la procédure "SDosier" (que j'ai recopié). Si je la fais fonctionner pas à pas, le résultat de sDossier me donne bien "Documents and settins\(mon nom)\Desktop". Par contre, lorsqu'elle continue, elle affiche le contenu dans "Documents and settins\(mon nom)"


Voici ma ligne de code:

Code :

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
 
Private Function CLASS(TYPE_REVISION As String)
...
    FolderName = BrowseFolderExplorer("Classement de courriel", , SDossier(0, 0))
    If BrowseForFolder = "" Then Exit Function
...
Function BrowseFolderExplorer(Optional DialogTitle As String, _
    Optional ViewType As MsoFileDialogView = _
        MsoFileDialogView.msoFileDialogViewSmallIcons, _
    Optional InitialDirectory As String) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' BrowseFolderExplorer
' This provides an Explorer-like Folder Open dialog.
' http://www.cpearson.com/excel/browsefolder.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim fDialog  As Office.FileDialog
    Dim varFile As Variant
    Dim ExcelApp
    Set ExcelApp = CreateObject("Excel.application")
    ExcelApp.Visible = False
    '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
 
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
 
Sub Serv081()
    Dim TYPE_REVISION As String
    TYPE_REVISION = "V"
    Call CLASS(TYPE_REVISION)
End Sub

Pour appeler ma macro, je vais dans la procédure "Serv081"
La valeur de ".InitialFileName" me donne bien mon bureau.

Pourquoi la fenêtre arrête à mon dossier et n'affiche pas le bureau?

Merci et bonne journée.

[Oliv-]

Bonjour
En pas à pas quand le dossier change ?

[Oliv-]

A corriger ainsi

Code :

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

1
2
3
    FolderName = BrowseFolderExplorer("Classement de courriel", , SDossier(0, 0) & "\")
    If FolderName = "" Then Exit Function
    MsgBox FolderName

[marycaLou]

Merci.
Cela fonctionne bien.

Par contre, c'est très lent probablement en raison de l'ouverture de Excel.

Au début, elle fonctionnait bien, sauf qu'elle ne prenait pas les raccourcis que les utilisateurs créent. À leur demande, j'essaie de trouver une solution.

Ce que vous m'avez proposé est très bien car elle m'affiche les raccourcis, mais est-ce qu'il y aurait moyen de ne pas ouvrir d'application (sauf Outlook) pour exécuter une macro comme celle-ci?

Merci

[Oliv-]

Bonjour,
Chez moi cela fonctionne vite et c'est un vieux pc.

Sinon en revenant au code initial de ton autre post

Tu crèes un USERFORM avec un bouton (CommandButton1) et une ListBox(ListBox1)

dans le code de ce formulaire tu mets:

Code :

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
Private Sub CommandButton1_Click()
    If Me.ListBox1.ListIndex = -1 Then Exit Sub
    If Me.ListBox1 = "Choisir un autre Dossier" Then
 
        Dim FolderName As String
        Dim ShellApp As Object
 
        '-----------------------------------------------------------------------
        ' Indique le dossier par défaut lors du lancement de la macro.
        ' Si vous désirez changer le dossier par défaut,
        '    modifier "= 0" pour tout autre endroit désiré. Exemple: "= C:\"
        '-----------------------------------------------------------------------
        OpenAt = 0            ' Modifier l'ouverture du dossier par défaut.
        'OpenAt = 0            ' OUVERTURE STANDARD SOUS LE BUREAU
        'OpenAt = "C:\"       ' OUVRIR DIRECTEMENT SOUS LE C:
        '                             (OU N'IMPORTE QUEL RACCOURCI)
        '-----------------------------------------------------------------------
        '-----------------------------------------------------------------------
 
 
        'Create a file browser window at the default folder
        '    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
        Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "S.V.P. Choisir un dossier :", 0, OpenAt)
 
        'Set the folder to that selected.  (On error in case cancelled)
        On Error Resume Next
        BrowseForFolder = ShellApp.Self.Path
        'Destroy the Shell Application
        Set ShellApp = Nothing
 
        'If BrowseForFolder = "" Then Exit Function
        If Right(BrowseForFolder, 1) <> "\" Then
            FolderName = BrowseForFolder & "\"
        Else
            FolderName = BrowseForFolder
        End If
        Me.ListBox1.AddItem FolderName
        Me.ListBox1 = FolderName
    End If
 
    'option 1
    'On recuperer dans le module la valeur de Listbox1 et ensuite seulement on ferme le formulaire
    'MsgBox Me.ListBox1
    Me.Hide
 
    'option 2
    'On renvoye la valeur dans une Variable PUBLIC que tu dois déclarer IMPERATIVEMENT dans un Module
    PublicDossier = Me.ListBox1
    'Unload.me
 
End Sub
 
 
Private Sub UserForm_Initialize()
    RecupFoldersShortCutsurBureau
    Me.ListBox1.AddItem "Choisir un autre Dossier"
End Sub
 
Sub RecupFoldersShortCutsurBureau()
    Dim Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim FileItem As Object
    Dim ObjShell, ObjFolder
    Set ObjShell = CreateObject("Shell.Application")
    For Each ObjFolder In ObjShell.Namespace(0).Items
        If ObjFolder.IsLink Then
            On Error Resume Next
            Set FileItem = Fso.GetFolder(ObjFolder.GetLink.Path)
            If Not FileItem Is Nothing Then
                'MsgBox ObjFolder.Path & vbNewLine & ObjFolder.GetLink.Path
                Me.ListBox1.AddItem ObjFolder.GetLink.Path
            End If
            Set FileItem = Nothing
        End If
    Next
    Set ObjFolder = Nothing
    Set ObjShell = Nothing
End Sub

dans un module

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Sub Choisir_Lnk_ou_autre_Dossier()
    Dim MonDossier As String
    UserForm1.Show
    'option 1
    MonDossier = UserForm2.ListBox1
    MsgBox MonDossier
    Unload UserForm1
 
    'option 2
    MsgBox PublicDossier
End Sub