XL 2016 VBA - Récupérer chemin du dossier "Téléchargements"

Deadpool_CC

XLDnaute Impliqué
Bonjour,

Les noms de dossiers spéciaux dans Windows sont des alias vers des répertoires. et la destination (l'emplacement) peut être personnalisé par l'utilisateur.
Pour certains dossier (comme le "Bureau"), la fonction .Specialfolders sait les gérer

Mais étrangement le Dossier "Téléchargements" ou "Downloads" n'est pas gérer par cette fonction. et je n'arrive pas à trouver un moyen de le récupérer.
ps : pour le moment (cf. mon code ci dessous) je construis le chemin ... mais si l'utilisateur à personnaliser l'emplacement je suis dans le chou ma bonne dame :)

Connaissez vous un moyen de récupérer l'emplacement de ce dossier spécial "Téléchargements" ?

Voici mon code VBA :
VB:
Public CheminFichierEdition As String
Public CheminTelechargements As String

'------------------------------------------------------------------
' Obtenir le chemin d'un dossier spécial
'
Function ObtenirCheminSpecial(Dossier As String) As String
    '
    ' Cette fonction traite pour le moment les valeurs suivantes
    ' anglaise & française de 'Dossier' :
    ' Desktop ; Bureau
    ' Downloads ; Téléchargements
    ' MyDocuments ; Mes Documents
    '
    ' Pour les autres valeurs ont fait une tentative mais résultat non garanti
   
    On Error GoTo ObtenirCheminSpecialError
   
    Dim Chemin As String
    Chemin = ""
    Dim oWSHShell As Object
    Set oWSHShell = CreateObject("WScript.Shell")
   
    Select Case Dossier
        Case "Desktop", "Bureau"
            Chemin = oWSHShell.SpecialFolders("Desktop")
        Case "Downloads", "Téléchargements"
            Chemin = "C:\Users\" & Environ("USERNAME") & "\Downloads"
        Case "MyDocuments", "Mes documents"
            Chemin = oWSHShell.SpecialFolders("MyDocuments")
        Case Else
            Chemin = oWSHShell.SpecialFolders(Dossier)
    End Select
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminSpecial = Chemin
Exit Function
ObtenirCheminSpecialError:
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminSpecial = ""
End Function

Sub Test()
'
' ImportCSV Macro
'
CheminFichierEdition = ThisWorkbook.Path
CheminTelechargements = ObtenirCheminSpecial("Downloads")

MsgBox "Edit : " & CheminFichierEdition & vbCrLf & "téléchargements : " & CheminTelechargements

End Sub


A titre d'info :
J'ai aussi chercher dans Environ() mais ce dossier n'est pas déclaré non plus
Lla procédure VBA qui les sort toutes les variables d'environnement :
Code:
Sub AfficheInformationsSysteme()
For VariableSysteme = 1 To 255
    If Environ(VariableSysteme) = "" Then Exit For
    VariableValeur = Split(Environ(VariableSysteme), "=")
    ActiveSheet.Cells(VariableSysteme, 1).Value = VariableSysteme
    ActiveSheet.Cells(VariableSysteme, 2).Value = VariableValeur(0)
    ActiveSheet.Cells(VariableSysteme, 3).Value = VariableValeur(1)
Next VariableSysteme
End Sub

Merci d'avance pour votre aide :)
 
Solution
Bonjour,

J'ai trouvé ceci* qui fonctionne chez moi :
VB:
' Source : https://stackoverflow.com/questions/23070299/get-the-windows-download-folders-path
' Downloads Folder Registry Key
Private Const GUID_WIN_DOWNLOADS_FOLDER As String = "{374DE290-123F-4565-9164-39C4925E467B}"
Private Const KEY_PATH As String = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\"
'
Public Function GetCurrentUserDownloadsPath()
    Dim pathTmp As String

    On Error Resume Next
    pathTmp = RegKeyRead(KEY_PATH & GUID_WIN_DOWNLOADS_FOLDER)
    pathTmp = Replace$(pathTmp, "%USERPROFILE%", Environ$("USERPROFILE"))
    On Error GoTo 0

    GetCurrentUserDownloadsPath = pathTmp
End Function
'
Private Function...

Hasco

XLDnaute Barbatruc
Bonjour,

J'ai trouvé ceci* qui fonctionne chez moi :
VB:
' Source : https://stackoverflow.com/questions/23070299/get-the-windows-download-folders-path
' Downloads Folder Registry Key
Private Const GUID_WIN_DOWNLOADS_FOLDER As String = "{374DE290-123F-4565-9164-39C4925E467B}"
Private Const KEY_PATH As String = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\"
'
Public Function GetCurrentUserDownloadsPath()
    Dim pathTmp As String

    On Error Resume Next
    pathTmp = RegKeyRead(KEY_PATH & GUID_WIN_DOWNLOADS_FOLDER)
    pathTmp = Replace$(pathTmp, "%USERPROFILE%", Environ$("USERPROFILE"))
    On Error GoTo 0

    GetCurrentUserDownloadsPath = pathTmp
End Function
'
Private Function RegKeyRead(registryKey As String) As String
' Returns the value of a windows registry key.
    Dim winScriptShell As Object

    On Error Resume Next
    Set winScriptShell = VBA.CreateObject("WScript.Shell")  ' access Windows scripting
    RegKeyRead = winScriptShell.RegRead(registryKey)    ' read key from registry
End Function
Source :
cordialement
 

Discussions similaires

Statistiques des forums

Discussions
300 889
Messages
1 988 142
Membres
210 082
dernier inscrit
bernard.dufaure.47@gmail.