在OneDrive中创建新文件夹

Question

多年来一直在使用下面的代码。它创建新的文件夹，并将其命名为下一个工作日的日期+在其中添加另一个文件夹，名为"；VO"；。代码得到两个"；fPath"-线停顿的那个是原来的那个。有了这个，我可以四处移动我的文件，代码仍然会根据ThisWorkbook的位置创建新的文件夹。

然而，对于OneDrive；fPath"-行以"；运行时错误52：错误的文件名或编号"；，标记线CCD_ 1。为什么此代码在OneDrive中不起作用？当我改变"；fPath"-行到完整的地址，它工作得很好。

Sub NewFolderNextWorkDay()
Dim FSO As Object
Dim fsoObj As Object
Dim NeArbDg As Double
NeArbDg = Application.WorkDay(Date, 1)
Dim Dato As String
Dim fPath As String
Dim EndDir1, EndDir2 As String
Dato = Format(NeArbDg, "yyyy-mm-dd")
'fPath = ThisWorkbook.Path & ".."    '(old code, worked fine until OneDrive came along)
fPath = "C:UsersMyIdOneDrive - MyJobMine dokumenterPRODTEST2022"   '(new code, works ok with OneDrive)
EndDir1 = (fPath & Dato & "")
EndDir2 = (fPath & Dato & "VO")
Set fsoObj = CreateObject("Scripting.FileSystemObject")

With fsoObj

If Not .FolderExists(EndDir1) Then
.CreateFolder (EndDir1)
End If

If Not .FolderExists(EndDir2) Then
.CreateFolder (EndDir2)
End If

End With
End Sub

Answer 1

链接帖子中的此函数(https://stackoverflow.com/a/67582367/478884)似乎对我有效。当strCID没有内容时，我确实需要进行更改以解决问题。参见标有####的行

Function GetLocalFile(wb As Workbook) As String
' Set default return
GetLocalFile = wb.FullName
Const HKEY_CURRENT_USER = &H80000001
Dim strValue As String
Dim objReg As Object: Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\.rootdefault:StdRegProv")
Dim strRegPath As String: strRegPath = "SoftwareSyncEnginesProvidersOneDrive"
Dim arrSubKeys() As Variant
objReg.EnumKey HKEY_CURRENT_USER, strRegPath, arrSubKeys
Dim varKey As Variant
For Each varKey In arrSubKeys
' check if this key has a value named "UrlNamespace", and save the value to strValue
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "UrlNamespace", strValue
' If the namespace is in FullName, then we know we have a URL and need to get the path on disk
If InStr(wb.FullName, strValue) > 0 Then
Dim strTemp As String
Dim strCID As String
Dim strMountpoint As String

' Get the mount point for OneDrive
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "MountPoint", strMountpoint

' Get the CID
objReg.getStringValue HKEY_CURRENT_USER, strRegPath & varKey, "CID", strCID

' strip off the namespace and CID
If Len(strCID) > 0 Then strValue = strValue & "/" & strCID     '#####
strTemp = Right(wb.FullName, Len(wb.FullName) - Len(strValue)) '#####

' replace all forward slashes with backslashes
GetLocalFile = strMountpoint & "" & Replace(strTemp, "/", "")
Exit Function
End If
Next
End Function

Answer 2

将https://my....更改为C:users...:

Sub Sample()
GetLocalFile = Split(ThisWorkbook.Path, "/Documents")(2)
GetLocalFile = Replace(GetLocalFile, "/", "")
MyPath = Environ("onedrive") & "documents" & GetLocalFile
MkDir (MyPath & "New")
End Sub