我有一些需要知道 下载 文件夹路径的Excel VBA代码。我该如何做呢?
由于您可以在文件夹属性中移动 下载 文件夹(也是文档和大多数文件夹),所以环境变量(例如 %USERPROFILE%
)无法构建像 %USERPROFILE%\Downloads
这样的路径,而 WScript.Shell.SpecialFolders
不会列出下载文件夹。
我猜必须通过读取注册表来完成 ,但我对此一无所知。
谢谢!
我有一些需要知道 下载 文件夹路径的Excel VBA代码。我该如何做呢?
由于您可以在文件夹属性中移动 下载 文件夹(也是文档和大多数文件夹),所以环境变量(例如 %USERPROFILE%
)无法构建像 %USERPROFILE%\Downloads
这样的路径,而 WScript.Shell.SpecialFolders
不会列出下载文件夹。
我猜必须通过读取注册表来完成 ,但我对此一无所知。
谢谢!
这是来自@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
多在谷歌上查找,就能找到答案...
根据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}")
可获取当前用户的下载文件夹路径。
读取这样的路径的支持方式是使用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
$downloadsFolder = (New-Object -ComObject Shell.Application).NameSpace('shell:Downloads').Self.Path
关于如何运行 .ps1 文件,请参见这里。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
Sub GetDownloadedFolderFiles()
'
' Keep it simple - Paul Seré
'
Dim fso As New FileSystemObject
Dim flds As Folders
Dim fls As Files
Dim f As File
'Downloads folder for the actual user!
Set fls = fso.GetFolder("C:\Users\User\Downloads").Files
For Each f In fls
Debug.Print f.Name
Next
End Sub
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
Public Function Replace(strExpression As Variant, strSearch As String, StrReplace As String) As String
Dim lngStart As Long
If IsNull(strExpression) Then Exit Function
lngStart = 1
While InStr(lngStart, strExpression, strSearch) <> 0
lngStart = InStr(lngStart, strExpression, strSearch)
strExpression = Left(strExpression, lngStart - 1) & StrReplace & Mid(strExpression, lngStart + Len(strSearch))
lngStart = lngStart + Len(StrReplace)
Wend
Replace = strExpression
End Function
Function GetDownloadedFolderPath() As String
GetDownloadedFolderPath = RegKeyRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\{374DE290-123F-4565-9164-39C4925E467B}")
GetDownloadedFolderPath = Replace(GetDownloadedFolderPath, "%USERPROFILE%", Environ$("USERPROFILE"))
End Function
c:\Users\simoco
,但是文档文件夹可以轻松移动到d:\stuff
。 - s_aEnviron("USERPROFILE") & "\Downloads"
- 但这并不能回答问题,因为用户可能会重命名他的下载文件夹。 - assylias