1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
| Option Explicit
Public Function OneDriveLocalFilePath(Optional ByRef OneDriveFilePath As String) As String
' https://answers.microsoft.com/en-us/msoffice/forum/all/the-onedrive-nightmare-continues-thisworkbookpath/3350ec2c-e75b-4bfd-acb7-d6ce71bd9c51
' Renvoie le chemin d'accès au fichier local à partir d'une URL vers un fichier stocké dans un dossier OneDrive ou Sharepoint
' Pour une raison quelconque, les propriétés Path et FullName du classeur Excel renvoient des URL au lieu de chemins locaux
' OneDriveFilePath - Tout chemin local ou URL valide référençant un fichier OneDrive
' Si le chemin ne peut pas être résolu, le chemin d'origine est renvoyé
' Pour appeler la fonction : Debug.Print OneDriveLocalFilePath(ThisWorkbook.FullName)
Dim WScript As Object
Dim WinMgmtS As Object
Dim Result As String
Dim ProposedFilePath As String
Dim ConfirmedFilePath As String
Dim RegistryKey As Variant
Dim RegistryKeys As Variant
Dim Types As Variant
Dim CID As String
Dim MountPoint As String
Dim URLNamespace As String
Dim Path1 As String
Dim Path2 As String
Dim Directories As Variant
Dim ParentDirectory As String
' Default to the full name property of ThisWorkbook
If Len(OneDriveFilePath) = 0 Then
OneDriveFilePath = ThisWorkbook.FullName
End If
' Deterimine if the path is a URL or a local path
If Left(OneDriveFilePath, 8) = "https://" Then
' WScript and Winmgmts are used to navigate the registry
Set WScript = CreateObject("WScript.Shell")
Set WinMgmtS = GetObject("Winmgmts:root\default:StdRegProv")
' Enumerate the key HKEY_CURRENT_USER\SOFTWARE\SyncEngines\Providers\OneDrive
If WinMgmtS.EnumKey(&H80000001, "SOFTWARE\SyncEngines\Providers\OneDrive", RegistryKeys, Types) = 0 Then
For Each RegistryKey In RegistryKeys
' Each key has three interesting values:
' CID - Some hash code sometimes used in the path
' URLNameSpace - The URL to a parent directory in the cloud
' MountPoint - The local path OneDrive uses to mirror files found in the URLNameSpace address
CID = vbNullString
MountPoint = vbNullString
URLNamespace = vbNullString
ProposedFilePath = vbNullString
ConfirmedFilePath = vbNullString
On Error Resume Next
CID = WScript.RegRead("HKEY_CURRENT_USER\SOFTWARE\SyncEngines\Providers\OneDrive\" & RegistryKey & "\CID")
MountPoint = WScript.RegRead("HKEY_CURRENT_USER\SOFTWARE\SyncEngines\Providers\OneDrive\" & RegistryKey & "\MountPoint")
URLNamespace = WScript.RegRead("HKEY_CURRENT_USER\SOFTWARE\SyncEngines\Providers\OneDrive\" & RegistryKey & "\URLNamespace")
On Error GoTo 0
' It's not always clear how for down the folder tree the URL and the mount point go so the file's parent is
' pulled from the OneDrivePath so that it can be compared with and without
Directories = Split(OneDriveFilePath, "/")
ParentDirectory = Directories(UBound(Directories) - 1)
' Remove any trailing slash from the URL name space
If Right(URLNamespace, 1) = "/" Then
URLNamespace = Left(URLNamespace, Len(URLNamespace) - 1)
End If
' Build two paths to test against: one without the CID and one with the CID
Path1 = URLNamespace & "/"
Path2 = URLNamespace & "/" & CID & "/"
' Try the path without the CID
If Left(OneDriveFilePath, Len(Path1)) = Path1 Then
' Try building the final local path from the mount point path and the unmatched end of the OneDrive path
' and return it if the file exists
ProposedFilePath = MountPoint & "\" & Replace(Replace(Mid(OneDriveFilePath, Len(Path1) + 1), "/", "\"), "%20", Space(1))
If ExistingFile(ProposedFilePath) Then
ConfirmedFilePath = ProposedFilePath
Exit For
End If
' Try building the final local path from the mount point path and the unmatched end of the OneDrive path
' but without the first folder and return it if the file exists
If Right(MountPoint, Len(ParentDirectory)) = ParentDirectory Then
ProposedFilePath = Replace(Replace(Mid(OneDriveFilePath, Len(Path1) + 1), "/", "\"), "%20", Space(1))
ProposedFilePath = Mid(ProposedFilePath, InStr(ProposedFilePath, "\") + 1)
ProposedFilePath = MountPoint & "\" & ProposedFilePath
If ExistingFile(ProposedFilePath) Then
ConfirmedFilePath = ProposedFilePath
Exit For
End If
End If
End If
' Try building the final local path from the mount point path with the CID attached and the unmatched end
' of the OneDrive path and return it if the file exists
If Left(OneDriveFilePath, Len(Path2)) = Path2 Then
ProposedFilePath = Replace(Replace(Mid(OneDriveFilePath, Len(Path2)), "/", "\"), "%20", Space(1))
ProposedFilePath = Mid(ProposedFilePath, InStr(ProposedFilePath, "\") + 1)
ProposedFilePath = MountPoint & "\" & ProposedFilePath
If ExistingFile(ProposedFilePath) Then
ConfirmedFilePath = ProposedFilePath
Exit For
End If
End If
Next RegistryKey
End If
' Return the confirmed file path if a valid path was found
If Len(ConfirmedFilePath) > 0 Then
Result = ConfirmedFilePath
Else
Result = OneDriveFilePath
End If
Else
' The path is not a URL so return it as-is
Result = OneDriveFilePath
End If
'Pour supprimer le nom du fichier, ajouter par goninph
OneDriveLocalFilePath = Left(Result, InStrRev(Result, "\"))
End Function
Public Function ExistingFile(ByVal FilePath As String) As Boolean
' Renvoie True si le fichier existe, False sinon
' Cette routine n'utilise pas la technique Dir car la fonction Dir réinitialise tout processus Dir en cours
' FilePath - Chemin complet vers le dossier ou le fichier à évaluer
Dim Attributes As Long
On Error Resume Next
Attributes = GetAttr(FilePath)
ExistingFile = (Err.Number = 0) And (Attributes And vbDirectory) = 0
Err.Clear
End Function |
ThisWorkbook.Path et OneDrive
Répondre avec citation
et si celle-ci est pertinente pensez à voter 
Partager