获取Windows下载文件夹的路径

Question

我有一些Excel VBA代码需要知道下载文件夹路径.我怎么能这样做？

由于您可以移动" 下载"文件夹(以及" 文档"和大多数文件夹,通过文件夹属性),因此环境变量%USERPROFILE%无法构建类似的路径%USERPROFILE%\Downloads,WScript.Shell.SpecialFolders也不会列出"下载"文件夹.

我想必须要阅读注册表,但我对此毫无头绪.

谢谢!

Answer 1

找到答案谷歌多一点...

根据http://vba-corner.livejournal.com/3054.html，读取注册表的方式是：

'reads the value for the registry key i_RegKey
'if the key cannot be found, the return value is ""
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object

  On Error Resume Next
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'read key from registry
  RegKeyRead = myWS.RegRead(i_RegKey)
End Function

以及MSDN的http://msdn.microsoft.com/en-us/library/windows/desktop/dd378457(v=vs.85).aspx对应的Downloads文件夹的GUID ：

{374DE290-123F-4565-9164-39C4925E467B}

这样就RegKeyRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\{374DE290-123F-4565-9164-39C4925E467B}")产生了当前用户的Downloads文件夹路径。

Answer 2

简单的解决方案-通常有效

这是来自@assylias的评论。正如其他人提到的那样，如果用户更改了默认的“下载”位置，它将提供错误的文件夹路径-但这很简单。

Function GetDownloadsPath() As String
    GetDownloadsPath = Environ$("USERPROFILE") & "\Downloads"
End Function

最佳解决方案

发布的答案返回“％USERPROFILE％\ Downloads”。我不知道该怎么做，所以我在下面创建了函数。这将其转换为函数并返回实际路径。这样称呼：Debug.Print GetCurrentUserDownloadsPath或Debug.Print GetCurrentUserDownloadsPath。感谢@s_a展示了如何读取注册表项以及如何使用文件夹路径查找注册表项。

' 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

Answer 3

读取此类路径的受支持方法是使用该SHGetKnownFolderPath函数。

我写了这个 VBA 代码来做到这一点。它已经在 Excel 2000 中进行了测试。

它不适用于任何 64 位版本的 Office。我不知道它的 Unicode 恶作剧是否适用于 2000 年以后的 Office 版本。它并不漂亮。

Option Explicit

Private Type GuidType
  data1 As Long
  data2 As Long
  data3 As Long
  data4 As Long
End Type

Declare Function SHGetKnownFolderPath Lib "shell32.dll" (ByRef guid As GuidType, ByVal flags As Long, ByVal token As Long, ByRef hPath As Long) As Long
Declare Function lstrlenW Lib "kernel32.dll" (ByVal hString As Long) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMemory As Long)
Declare Sub RtlMoveMemory Lib "ntdll.dll" (ByVal dest As String, ByVal source As Long, ByVal count As Long)

'Read the location of the user's "Downloads" folder
Function DownloadsFolder() As String

' {374DE290-123F-4565-9164-39C4925E467B}
Dim FOLDERID_Downloads As GuidType
    FOLDERID_Downloads.data1 = &H374DE290
    FOLDERID_Downloads.data2 = &H4565123F
    FOLDERID_Downloads.data3 = &HC4396491
    FOLDERID_Downloads.data4 = &H7B465E92
Dim result As Long
Dim hPath As Long
Dim converted As String
Dim length As Long
    'A buffer for the string
    converted = String$(260, "*")
    'Convert it to UNICODE
    converted = StrConv(converted, vbUnicode)
    'Get the path
    result = SHGetKnownFolderPath(FOLDERID_Downloads, 0, 0, hPath)
    If result = 0 Then
        'Get its length
        length = lstrlenW(hPath)
        'Copy the allocated string over the VB string
        RtlMoveMemory converted, hPath, (length + 1) * 2
        'Truncate it
        converted = Mid$(converted, 1, length * 2)
        'Convert it to ANSI
        converted = StrConv(converted, vbFromUnicode)
        'Free the memory
        CoTaskMemFree hPath
        'Return the value
        DownloadsFolder = converted
    Else
        Error 1
    End If
End Function

Answer 4

上述注册表或其他解决方案都不是必需的。即使“我的文档”重定向到 OneDrive，以下操作也会执行此操作：

Function GetMyDocuments() As String
Dim oWSHShell As Object

Set oWSHShell = CreateObject("WScript.Shell")
GetMyDocuments = oWSHShell.SpecialFolders("MyDocuments")
Set oWSHShell = Nothing
End Function

或者获取桌面文件夹：

Function GetDesktop() As String
Dim oWSHShell As Object

Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
End Function

经过尝试、测试并且有效。