Excel VBA 获取物理位置,而不是 OneDrive URL
Excel VBA Get Physical Location, not OneDrive URL
我在 excel 中使用 VBA 创建了一些简单的文件,这些文件应该保存在与 excel 文件相同的位置。
我得到 excel 文件的位置:
ActiveWorkbook.Path
问题是这总是 returns OneDrive URL,像这样:
https://d.docs.live.net/641ebe6d8******/Work/Projects.......
我要查找的是我硬盘上的物理位置。
我已经尝试关闭计算机上的 OneDrive 应用程序,并从目录本身打开文件,但上面的位置仍然给我一个 OneDrive URL。
有什么想法可以代替我的硬盘上的目录路径吗?
解决方案是 OneDrive 设置。
取消选中“使用 Office 应用程序来 sunc 我打开的 Office 文件”将使其使用本地目录。即使在我的计算机上关闭 OneDrive 应用程序,此效果也是如此。
您可以使用下面的辅助函数获取文件的物理路径,即使它保存在 OneDrive/Microsoft Teams 文件夹中。
它基本上会遍历存储同步文件夹路径的 Windows 注册表项,以及 return 与您的文件 URL.
匹配的注册表项
Function GetWorkbookPath(Optional wb As Workbook)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose: Returns a workbook's physical path, even when they are saved in
' synced OneDrive Personal, OneDrive Business or Microsoft Teams folders.
' If no value is provided for wb, it's set to ThisWorkbook object instead.
' Author: Ricardo Gerbaudo
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If wb Is Nothing Then Set wb = ThisWorkbook
GetWorkbookPath = wb.Path
If InStr(1, wb.Path, "https://") <> 0 Then
Const HKEY_CURRENT_USER = &H80000001
Dim objRegistryProvider As Object
Dim strRegistryPath As String
Dim arrSubKeys()
Dim strSubKey As Variant
Dim strUrlNamespace As String
Dim strMountPoint As String
Dim strLocalPath As String
Dim strRemainderPath As String
Dim strLibraryType As String
Set objRegistryProvider = GetObject("winmgmts:{impersonationLevel=impersonate}!\.\root\default:StdRegProv")
strRegistryPath = "SOFTWARE\SyncEngines\Providers\OneDrive"
objRegistryProvider.EnumKey HKEY_CURRENT_USER, strRegistryPath, arrSubKeys
For Each strSubKey In arrSubKeys
objRegistryProvider.GetStringValue HKEY_CURRENT_USER, strRegistryPath & "\" & strSubKey & "\", "UrlNamespace", strUrlNamespace
If InStr(1, wb.Path, strUrlNamespace) <> 0 Or InStr(1, strUrlNamespace, wb.Path) <> 0 Then
objRegistryProvider.GetStringValue HKEY_CURRENT_USER, strRegistryPath & "\" & strSubKey & "\", "MountPoint", strMountPoint
objRegistryProvider.GetStringValue HKEY_CURRENT_USER, strRegistryPath & "\" & strSubKey & "\", "LibraryType", strLibraryType
If InStr(1, wb.Path, strUrlNamespace) <> 0 Then
strRemainderPath = Replace(wb.Path, strUrlNamespace, vbNullString)
Else
GetWorkbookPath = strMountPoint
Exit Function
End If
'If OneDrive Personal, skips the GUID part of the URL to match with physical path
If InStr(1, strUrlNamespace, "https://d.docs.live.net") <> 0 Then
If InStr(2, strRemainderPath, "/") = 0 Then
strRemainderPath = vbNullString
Else
strRemainderPath = Mid(strRemainderPath, InStr(2, strRemainderPath, "/"))
End If
End If
'If OneDrive Business, adds extra slash at the start of string to match the pattern
strRemainderPath = IIf(InStr(1, strUrlNamespace, "my.sharepoint.com") <> 0, "/", vbNullString) & strRemainderPath
strLocalPath = ""
If (InStr(1, strRemainderPath, "/")) <> 0 Then
strLocalPath = Mid(strRemainderPath, InStr(1, strRemainderPath, "/"))
strLocalPath = Replace(strLocalPath, "/", "\")
End If
strLocalPath = strMountPoint & strLocalPath
GetWorkbookPath = strLocalPath
If Dir(GetWorkbookPath & "\" & wb.Name) <> "" Then Exit Function
End If
Next
End If
End Function
我在 excel 中使用 VBA 创建了一些简单的文件,这些文件应该保存在与 excel 文件相同的位置。
我得到 excel 文件的位置:
ActiveWorkbook.Path
问题是这总是 returns OneDrive URL,像这样:
https://d.docs.live.net/641ebe6d8******/Work/Projects.......
我要查找的是我硬盘上的物理位置。
我已经尝试关闭计算机上的 OneDrive 应用程序,并从目录本身打开文件,但上面的位置仍然给我一个 OneDrive URL。
有什么想法可以代替我的硬盘上的目录路径吗?
解决方案是 OneDrive 设置。
取消选中“使用 Office 应用程序来 sunc 我打开的 Office 文件”将使其使用本地目录。即使在我的计算机上关闭 OneDrive 应用程序,此效果也是如此。
您可以使用下面的辅助函数获取文件的物理路径,即使它保存在 OneDrive/Microsoft Teams 文件夹中。
它基本上会遍历存储同步文件夹路径的 Windows 注册表项,以及 return 与您的文件 URL.
匹配的注册表项Function GetWorkbookPath(Optional wb As Workbook)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Purpose: Returns a workbook's physical path, even when they are saved in
' synced OneDrive Personal, OneDrive Business or Microsoft Teams folders.
' If no value is provided for wb, it's set to ThisWorkbook object instead.
' Author: Ricardo Gerbaudo
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If wb Is Nothing Then Set wb = ThisWorkbook
GetWorkbookPath = wb.Path
If InStr(1, wb.Path, "https://") <> 0 Then
Const HKEY_CURRENT_USER = &H80000001
Dim objRegistryProvider As Object
Dim strRegistryPath As String
Dim arrSubKeys()
Dim strSubKey As Variant
Dim strUrlNamespace As String
Dim strMountPoint As String
Dim strLocalPath As String
Dim strRemainderPath As String
Dim strLibraryType As String
Set objRegistryProvider = GetObject("winmgmts:{impersonationLevel=impersonate}!\.\root\default:StdRegProv")
strRegistryPath = "SOFTWARE\SyncEngines\Providers\OneDrive"
objRegistryProvider.EnumKey HKEY_CURRENT_USER, strRegistryPath, arrSubKeys
For Each strSubKey In arrSubKeys
objRegistryProvider.GetStringValue HKEY_CURRENT_USER, strRegistryPath & "\" & strSubKey & "\", "UrlNamespace", strUrlNamespace
If InStr(1, wb.Path, strUrlNamespace) <> 0 Or InStr(1, strUrlNamespace, wb.Path) <> 0 Then
objRegistryProvider.GetStringValue HKEY_CURRENT_USER, strRegistryPath & "\" & strSubKey & "\", "MountPoint", strMountPoint
objRegistryProvider.GetStringValue HKEY_CURRENT_USER, strRegistryPath & "\" & strSubKey & "\", "LibraryType", strLibraryType
If InStr(1, wb.Path, strUrlNamespace) <> 0 Then
strRemainderPath = Replace(wb.Path, strUrlNamespace, vbNullString)
Else
GetWorkbookPath = strMountPoint
Exit Function
End If
'If OneDrive Personal, skips the GUID part of the URL to match with physical path
If InStr(1, strUrlNamespace, "https://d.docs.live.net") <> 0 Then
If InStr(2, strRemainderPath, "/") = 0 Then
strRemainderPath = vbNullString
Else
strRemainderPath = Mid(strRemainderPath, InStr(2, strRemainderPath, "/"))
End If
End If
'If OneDrive Business, adds extra slash at the start of string to match the pattern
strRemainderPath = IIf(InStr(1, strUrlNamespace, "my.sharepoint.com") <> 0, "/", vbNullString) & strRemainderPath
strLocalPath = ""
If (InStr(1, strRemainderPath, "/")) <> 0 Then
strLocalPath = Mid(strRemainderPath, InStr(1, strRemainderPath, "/"))
strLocalPath = Replace(strLocalPath, "/", "\")
End If
strLocalPath = strMountPoint & strLocalPath
GetWorkbookPath = strLocalPath
If Dir(GetWorkbookPath & "\" & wb.Name) <> "" Then Exit Function
End If
Next
End If
End Function