Return Excel VBA 宏 OneDrive 本地路径 - 可能的线索
Return Excel VBA Macro OneDrive Local Path - Possible Lead
我有一个很多人需要访问的电子表格（在共享点上），出于某些原因，我们需要在本地执行此操作（同步）。
然而，由于每个用户的知识水平，问题和错误不断出现，电子表格需要有结构和一致性，所以为了实现这一点，我创建了一个带有一组参数的用户表单来帮助人们输入准确的数据并避免错误。
投标登记册，用于录入客户、客户联系方式、投标信息，生成报价单、文件夹、文件名等
在 OneDrive/Sharepoint 路径更改之前（以前文件路径是本地路径，现在是共享点 URL）
我有一个宏 运行 当用户单击一个按钮时，它会在相关的本地共享点目录中创建一个适当命名的文件夹，并在该文件夹中创建一组标准文件夹（客户文档、合同、产品文件、图纸等），然后打开投标表格并将其保存在创建的文件夹中。文件名（报价编号）用于从投标登记簿中查找查询 return 所有 client/contact/quote 信息。
由于 Sharepoint 已将其路径协议从本地更改为 URL，我无法使其正常工作，导致手动过程，因此导致错误和不一致。
我到处搜索使用 VBA 在共享点上创建文件夹和文件的方法，以及与本地路径交互的方法，而不是禁用“使用 Office 应用程序同步我的 Office 文件”打开”（文件协作需要此功能）
当我找到一种将 URL 转换为本地路径的方法时，我有一个希望，但是，这不是最佳解决方案，因为每个用户都在不同级别同步文件夹（也许有人可以帮助我确定路径，在 OneDrive 目录中搜索文件夹“2021 Tenders”和 return 路径的宏...认为这可能很慢）
但是，我注意到如果我转到“文件”>“信息”，会有一个“打开文件位置”按钮，它会直接将我带到文件的本地路径文件夹，它告诉我此信息位于 excel，必须有一种方法来检索它，我在我的任何搜索中都没有看到对此的引用，指出它后，是否有人对如何或是否可行有任何想法？
我试着录制了一个宏，但它根本没有注册。
如有任何帮助，我们将不胜感激，并提前致谢。
File > Info - Screenshot
这是我根据另一个答案组装的（见代码内的注释）。
代码属于我放在一起的一系列 类 但为了给你一个 复杂 简单的答案，把它放在一个模块中：
Option Explicit
Private Const ONEDRIVE_TENANTS_REGISTRY_FOLDER As String = "Software\Microsoft\OneDrive\Accounts\Business1\Tenants\"
Private Const ONEDRIVE_TOTAL_VERSIONS As Long = 3
Private Const ONEDRIVE_PATH_SLASHES As Long = 4
Const HKEY_CURRENT_USER = &H80000001
Public Function GetLocalWorkbookName(ByVal fullName As String, Optional ByVal PathOnly As Boolean = False) As String
' Credits:
'returns local wb path or empty string if local path not found
Dim localFolders As Collection
Dim localFolder As Variant
Dim evalPath As String
Dim result As String
Dim isOneDrivePath As Boolean
'Check if it looks like a OneDrive location
isOneDrivePath = InStr(1, fullName, "https://", vbTextCompare) > 0
If isOneDrivePath = False Then
result = fullName
Else
Set localFolders = GetLocalFolders
evalPath = RemoveTopFoldersByQty(fullName, ONEDRIVE_PATH_SLASHES)
For Each localFolder In localFolders
result = GetFilePathByRootFolder(localFolder, evalPath)
If result <> vbNullString Then Exit For
Next localFolder
End If
If PathOnly Then
GetLocalWorkbookName = RemoveFileNameFromPath(result)
Else
GetLocalWorkbookName = result
End If
End Function
Public Function GetLocalFolders() As Collection
Dim tempCollection As Collection
Dim tenantFolders As Variant
Dim localFolders As Variant
Dim tenantCounter As Long
Set tempCollection = New Collection
' Look in onedrive for business tenant's folders
tenantFolders = GetRegistrySubKeys(ONEDRIVE_TENANTS_REGISTRY_FOLDER)
For tenantCounter = 0 To UBound(tenantFolders)
localFolders = GetRegistryValues(ONEDRIVE_TENANTS_REGISTRY_FOLDER & "\" & tenantFolders(tenantCounter) & "\")
AddArrayItemsToCollection tempCollection, localFolders
Next tenantCounter
' Add the onedrive consumer folder
tempCollection.Add Environ$("OneDriveConsumer")
Set GetLocalFolders = tempCollection
End Function
Public Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
RemoveTopFolderFromPath = Mid$(ShortName, InStr(ShortName, "\") + 1)
End Function
Public Function RemoveTopFoldersByQty(ByVal FullPath As String, ByVal FolderQty As Long) As String
Dim counter As Long
Dim evalPath As String
evalPath = Replace(FullPath, "/", "\")
For counter = 1 To FolderQty
evalPath = RemoveTopFolderFromPath(evalPath)
Next counter
RemoveTopFoldersByQty = evalPath
End Function
Public Function RemoveFileNameFromPath(ByVal ShortName As String) As String
RemoveFileNameFromPath = Mid$(ShortName, 1, Len(ShortName) - InStr(StrReverse(ShortName), "\"))
End Function
Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
Dim result As String
Dim evalPath As String
Dim testFilePath As String
Dim oneDrivePathFound As Boolean
evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
Do While evalPath Like "*\*"
testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
If Not (Dir(testFilePath)) = vbNullString Then
oneDrivePathFound = True
Exit Do
End If
'remove top folder in path
evalPath = RemoveTopFolderFromPath(evalPath)
Loop
If oneDrivePathFound = True Then
result = testFilePath
Else
result = vbNullString
End If
GetFilePathByRootFolder = result
End Function
Public Function GetRegistrySubKeys(ByVal pathToFolder As String) As Variant
' Credits:
Dim registryObject As Object
Dim computerID As String
Dim subkeys() As Variant
'Dim key As Variant
computerID = "."
Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
computerID & "\root\default:StdRegProv")
registryObject.EnumKey HKEY_CURRENT_USER, pathToFolder, subkeys
GetRegistrySubKeys = subkeys
'For Each key In subKeys
' Debug.Print key
'Next
End Function
Public Function GetRegistryValues(ByVal pathToFolder As String) As Variant
' Credits:
Dim registryObject As Object
Dim computerID As String
Dim values() As Variant
Dim valuesTypes() As Variant
'Dim value As Variant
computerID = "."
Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
computerID & "\root\default:StdRegProv")
registryObject.EnumValues HKEY_CURRENT_USER, pathToFolder, values, valuesTypes
GetRegistryValues = values
'For Each value In values
' Debug.Print value
'Next
End Function
Public Sub AddArrayItemsToCollection(ByVal evalCollection As Collection, ByVal evalArray As Variant)
Dim item As Variant
For Each item In evalArray
evalCollection.Add item
Next item
End Sub
并这样称呼它：
? GetLocalWorkbookName(ThisWorkbook.fullName, true)
希望对您有所帮助，如果有效请告诉我
该代码非常适合每个 onedrive/sharepoint 根同步文件夹（顶级）的子文件夹中的文件
但如果文件本身位于顶层则不然
我逐步查看代码以查看它通过每个斜杠过滤的位置
我在“GetFilePathByRootFolder”函数中从“do while”更改为“for”。
使用“do while”循环计算斜杠的数量，然后使用附加 运行 对斜杠 +1 的数量执行“for”循环到“RemoveTopFolderFromPath”，只留下文件名进行最后一次搜索文件名的根文件夹。
希望这是有道理的。
Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
Dim result As String
Dim evalPath As String
Dim testFilePath As String
Dim slashCounter As Integer 'added by AC
Dim i As Integer 'added by AC
Dim oneDrivePathFound As Boolean
evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
slashCounter = 0 'added by AC
Do While evalPath Like "*\*" 'added by AC
slashCounter = slashCounter + 1 'added by AC
evalPath = RemoveTopFolderFromPath(evalPath) 'added by AC
Loop 'added by AC
slashCounter = slashCounter + 1
evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
For i = 1 To slashCounter 'added by AC
testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath 'added by AC
Debug.Print testFilePath 'added by AC
If Not (Dir(testFilePath)) = vbNullString Then 'added by AC
oneDrivePathFound = True 'added by AC
Exit For 'added by AC
End If 'added by AC
'remove top folder in path 'added by AC
evalPath = RemoveTopFolderFromPath(evalPath) 'added by AC
Next i 'added by AC
' Do While evalPath Like "*\*" ' change loop to "for each \ in evalPath +1"
' testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
' Debug.Print testFilePath
' If Not (Dir(testFilePath)) = vbNullString Then
' oneDrivePathFound = True
' Exit Do 'exit for
' End If
' 'remove top folder in path
' evalPath = RemoveTopFolderFromPath(evalPath)
' Loop
If oneDrivePathFound = True Then
result = testFilePath
Else
result = vbNullString
End If
GetFilePathByRootFolder = result
End Function
这对我有用。我使用了环境变量。
OneDrive = Environ("OneDrive")
CurPath = Application.ThisWorkbook.Path
If (InStr(1, Left(CurPath, 4), "http", vbTextCompare)) Then
SubPathPos = InStr(30, CurPath, "/", vbTextCompare)
CurPath = OneDrive & Right(CurPath, Len(CurPath) - SubPathPos + 1)
End If
ChDir (CurPath)
我有一个很多人需要访问的电子表格（在共享点上），出于某些原因，我们需要在本地执行此操作（同步）。
然而，由于每个用户的知识水平，问题和错误不断出现，电子表格需要有结构和一致性，所以为了实现这一点，我创建了一个带有一组参数的用户表单来帮助人们输入准确的数据并避免错误。
投标登记册，用于录入客户、客户联系方式、投标信息，生成报价单、文件夹、文件名等
在 OneDrive/Sharepoint 路径更改之前（以前文件路径是本地路径，现在是共享点 URL） 我有一个宏 运行 当用户单击一个按钮时，它会在相关的本地共享点目录中创建一个适当命名的文件夹，并在该文件夹中创建一组标准文件夹（客户文档、合同、产品文件、图纸等），然后打开投标表格并将其保存在创建的文件夹中。文件名（报价编号）用于从投标登记簿中查找查询 return 所有 client/contact/quote 信息。
由于 Sharepoint 已将其路径协议从本地更改为 URL，我无法使其正常工作，导致手动过程，因此导致错误和不一致。
我到处搜索使用 VBA 在共享点上创建文件夹和文件的方法，以及与本地路径交互的方法，而不是禁用“使用 Office 应用程序同步我的 Office 文件”打开”（文件协作需要此功能） 当我找到一种将 URL 转换为本地路径的方法时，我有一个希望，但是，这不是最佳解决方案，因为每个用户都在不同级别同步文件夹（也许有人可以帮助我确定路径，在 OneDrive 目录中搜索文件夹“2021 Tenders”和 return 路径的宏...认为这可能很慢）
但是，我注意到如果我转到“文件”>“信息”，会有一个“打开文件位置”按钮，它会直接将我带到文件的本地路径文件夹，它告诉我此信息位于 excel，必须有一种方法来检索它，我在我的任何搜索中都没有看到对此的引用，指出它后，是否有人对如何或是否可行有任何想法？ 我试着录制了一个宏，但它根本没有注册。
如有任何帮助，我们将不胜感激，并提前致谢。
File > Info - Screenshot
这是我根据另一个答案组装的（见代码内的注释）。
代码属于我放在一起的一系列 类 但为了给你一个 复杂 简单的答案，把它放在一个模块中：
Option Explicit
Private Const ONEDRIVE_TENANTS_REGISTRY_FOLDER As String = "Software\Microsoft\OneDrive\Accounts\Business1\Tenants\"
Private Const ONEDRIVE_TOTAL_VERSIONS As Long = 3
Private Const ONEDRIVE_PATH_SLASHES As Long = 4
Const HKEY_CURRENT_USER = &H80000001
Public Function GetLocalWorkbookName(ByVal fullName As String, Optional ByVal PathOnly As Boolean = False) As String
' Credits:
'returns local wb path or empty string if local path not found
Dim localFolders As Collection
Dim localFolder As Variant
Dim evalPath As String
Dim result As String
Dim isOneDrivePath As Boolean
'Check if it looks like a OneDrive location
isOneDrivePath = InStr(1, fullName, "https://", vbTextCompare) > 0
If isOneDrivePath = False Then
result = fullName
Else
Set localFolders = GetLocalFolders
evalPath = RemoveTopFoldersByQty(fullName, ONEDRIVE_PATH_SLASHES)
For Each localFolder In localFolders
result = GetFilePathByRootFolder(localFolder, evalPath)
If result <> vbNullString Then Exit For
Next localFolder
End If
If PathOnly Then
GetLocalWorkbookName = RemoveFileNameFromPath(result)
Else
GetLocalWorkbookName = result
End If
End Function
Public Function GetLocalFolders() As Collection
Dim tempCollection As Collection
Dim tenantFolders As Variant
Dim localFolders As Variant
Dim tenantCounter As Long
Set tempCollection = New Collection
' Look in onedrive for business tenant's folders
tenantFolders = GetRegistrySubKeys(ONEDRIVE_TENANTS_REGISTRY_FOLDER)
For tenantCounter = 0 To UBound(tenantFolders)
localFolders = GetRegistryValues(ONEDRIVE_TENANTS_REGISTRY_FOLDER & "\" & tenantFolders(tenantCounter) & "\")
AddArrayItemsToCollection tempCollection, localFolders
Next tenantCounter
' Add the onedrive consumer folder
tempCollection.Add Environ$("OneDriveConsumer")
Set GetLocalFolders = tempCollection
End Function
Public Function RemoveTopFolderFromPath(ByVal ShortName As String) As String
RemoveTopFolderFromPath = Mid$(ShortName, InStr(ShortName, "\") + 1)
End Function
Public Function RemoveTopFoldersByQty(ByVal FullPath As String, ByVal FolderQty As Long) As String
Dim counter As Long
Dim evalPath As String
evalPath = Replace(FullPath, "/", "\")
For counter = 1 To FolderQty
evalPath = RemoveTopFolderFromPath(evalPath)
Next counter
RemoveTopFoldersByQty = evalPath
End Function
Public Function RemoveFileNameFromPath(ByVal ShortName As String) As String
RemoveFileNameFromPath = Mid$(ShortName, 1, Len(ShortName) - InStr(StrReverse(ShortName), "\"))
End Function
Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
Dim result As String
Dim evalPath As String
Dim testFilePath As String
Dim oneDrivePathFound As Boolean
evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
Do While evalPath Like "*\*"
testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
If Not (Dir(testFilePath)) = vbNullString Then
oneDrivePathFound = True
Exit Do
End If
'remove top folder in path
evalPath = RemoveTopFolderFromPath(evalPath)
Loop
If oneDrivePathFound = True Then
result = testFilePath
Else
result = vbNullString
End If
GetFilePathByRootFolder = result
End Function
Public Function GetRegistrySubKeys(ByVal pathToFolder As String) As Variant
' Credits:
Dim registryObject As Object
Dim computerID As String
Dim subkeys() As Variant
'Dim key As Variant
computerID = "."
Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
computerID & "\root\default:StdRegProv")
registryObject.EnumKey HKEY_CURRENT_USER, pathToFolder, subkeys
GetRegistrySubKeys = subkeys
'For Each key In subKeys
' Debug.Print key
'Next
End Function
Public Function GetRegistryValues(ByVal pathToFolder As String) As Variant
' Credits:
Dim registryObject As Object
Dim computerID As String
Dim values() As Variant
Dim valuesTypes() As Variant
'Dim value As Variant
computerID = "."
Set registryObject = GetObject("winmgmts:{impersonationLevel=impersonate}!\" & _
computerID & "\root\default:StdRegProv")
registryObject.EnumValues HKEY_CURRENT_USER, pathToFolder, values, valuesTypes
GetRegistryValues = values
'For Each value In values
' Debug.Print value
'Next
End Function
Public Sub AddArrayItemsToCollection(ByVal evalCollection As Collection, ByVal evalArray As Variant)
Dim item As Variant
For Each item In evalArray
evalCollection.Add item
Next item
End Sub
并这样称呼它：
? GetLocalWorkbookName(ThisWorkbook.fullName, true)
希望对您有所帮助，如果有效请告诉我
该代码非常适合每个 onedrive/sharepoint 根同步文件夹（顶级）的子文件夹中的文件 但如果文件本身位于顶层则不然
我逐步查看代码以查看它通过每个斜杠过滤的位置 我在“GetFilePathByRootFolder”函数中从“do while”更改为“for”。 使用“do while”循环计算斜杠的数量，然后使用附加 运行 对斜杠 +1 的数量执行“for”循环到“RemoveTopFolderFromPath”，只留下文件名进行最后一次搜索文件名的根文件夹。
希望这是有道理的。
Public Function GetFilePathByRootFolder(ByVal RootFolder As String, ByVal SearchPath As String) As String
Dim result As String
Dim evalPath As String
Dim testFilePath As String
Dim slashCounter As Integer 'added by AC
Dim i As Integer 'added by AC
Dim oneDrivePathFound As Boolean
evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
slashCounter = 0 'added by AC
Do While evalPath Like "*\*" 'added by AC
slashCounter = slashCounter + 1 'added by AC
evalPath = RemoveTopFolderFromPath(evalPath) 'added by AC
Loop 'added by AC
slashCounter = slashCounter + 1
evalPath = IIf(InStr(SearchPath, "\") = 0, "\", vbNullString) & SearchPath
For i = 1 To slashCounter 'added by AC
testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath 'added by AC
Debug.Print testFilePath 'added by AC
If Not (Dir(testFilePath)) = vbNullString Then 'added by AC
oneDrivePathFound = True 'added by AC
Exit For 'added by AC
End If 'added by AC
'remove top folder in path 'added by AC
evalPath = RemoveTopFolderFromPath(evalPath) 'added by AC
Next i 'added by AC
' Do While evalPath Like "*\*" ' change loop to "for each \ in evalPath +1"
' testFilePath = RootFolder & IIf(Left$(evalPath, 1) <> "\", "\", vbNullString) & evalPath
' Debug.Print testFilePath
' If Not (Dir(testFilePath)) = vbNullString Then
' oneDrivePathFound = True
' Exit Do 'exit for
' End If
' 'remove top folder in path
' evalPath = RemoveTopFolderFromPath(evalPath)
' Loop
If oneDrivePathFound = True Then
result = testFilePath
Else
result = vbNullString
End If
GetFilePathByRootFolder = result
End Function
这对我有用。我使用了环境变量。
OneDrive = Environ("OneDrive")
CurPath = Application.ThisWorkbook.Path
If (InStr(1, Left(CurPath, 4), "http", vbTextCompare)) Then
SubPathPos = InStr(30, CurPath, "/", vbTextCompare)
CurPath = OneDrive & Right(CurPath, Len(CurPath) - SubPathPos + 1)
End If
ChDir (CurPath)