├── .gitattributes ├── .github ├── FUNDING.yml ├── ISSUE_TEMPLATE │ ├── bug_report.md │ ├── feature_request.md │ └── getlocalpath-getremotepath-bug-report.md └── workflows │ └── comment-filter.yml ├── .gitignore ├── LICENSE ├── README.md └── src ├── Demo └── DemoLibFileTools.bas ├── LibFileTools.bas └── UDF_FileTools.bas /.gitattributes: -------------------------------------------------------------------------------- 1 | *.bas -text linguist-language=VBA 2 | *.frm -text linguist-language=VBA 3 | *.cls -text linguist-language=VBA -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: [cristianbuse] 2 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: Bug 5 | labels: bug 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Describe the bug** 11 | A clear and concise description of what the bug is. 12 | 13 | **To Reproduce** 14 | Steps to reproduce the behavior: 15 | 1. Go to '...' 16 | 2. Click on '....' 17 | 3. Scroll down to '....' 18 | 4. ... 19 | 5. See error 20 | 21 | **Expected behavior** 22 | A clear and concise description of what you expected to happen. 23 | 24 | **Screenshots** 25 | If applicable, add screenshots to help explain your problem. 26 | 27 | **Version (please complete the following information):** 28 | - OS: [e.g. Win, Mac] 29 | - VBA Version [e.g. VBA7] 30 | - Bitness [e.g x32, x64] 31 | 32 | Run this code for quick version: 33 | ```VBA 34 | Public Sub ShowVBInfo() 35 | Dim res(0 To 2) As String 36 | #If Mac Then 37 | res(0) = "Mac" 38 | #Else 39 | res(0) = "Win" 40 | #End If 41 | #If VBA7 Then 42 | res(1) = "VBA7" 43 | #Else 44 | res(1) = "VBA6" 45 | #End If 46 | #If Win64 Then 47 | res(2) = "x64" 48 | #Else 49 | res(2) = "x32" 50 | #End If 51 | MsgBox Join(res, " ") 52 | End Sub 53 | ``` 54 | 55 | **Additional context** 56 | Add any other context about the problem here. 57 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: New Feature Request 5 | labels: enhancement 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] 12 | 13 | **Describe the solution you'd like** 14 | A clear and concise description of what you want to happen. 15 | 16 | **Describe alternatives you've considered** 17 | A clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | Add any other context or screenshots about the feature request here. 21 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/getlocalpath-getremotepath-bug-report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: GetLocalPath GetRemotePath Bug Report 3 | about: Issue related to UNC / OneDrive / SharePoint path conversion 4 | title: Local/Remote Path Conversion Bug 5 | labels: bug 6 | assignees: '' 7 | 8 | --- 9 | 10 | Thank you for opening a new issue! Please read the below and delete all unwanted text/sections before you submit your issue. 11 | 12 | **Diagnostics** 13 | Please run the ```CreateODDiagnosticsFile``` private method from the ```LibFileTools``` module. You can run it in several ways: 14 | 1. Place the mouse cursor within the method and press F5 or the Run button in the VBA IDE (VBE) 15 | 2. Type ```Run "LibFileTools.CreateODDiagnosticsFile"``` in your Immediate window and press Enter 16 | 3. Assign the macro to a button or shape within your host Application and then press it 17 | 18 | Once ran, please post the resulting text file ```"DiagnosticsOD.txt"``` here. Or copy-paste its contents. 19 | You might need to anonymize some of the information, like username, before you make it publicly available here. 20 | 21 | **Describe the bug** 22 | A clear and concise description of what the bug is. 23 | 24 | **To Reproduce** 25 | Steps to reproduce the behavior: 26 | 1. Go to '...' 27 | 2. Click on '....' 28 | 3. Scroll down to '....' 29 | 4. ... 30 | 5. See error 31 | 32 | **Additional context** 33 | Add any other context about the problem here. 34 | -------------------------------------------------------------------------------- /.github/workflows/comment-filter.yml: -------------------------------------------------------------------------------- 1 | name: Check for Spammy Issue Comments 2 | 3 | on: 4 | issue_comment: 5 | types: [created, edited] 6 | 7 | permissions: 8 | issues: write 9 | 10 | jobs: 11 | comment-filter: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - name: Comment filter 15 | uses: DecimalTurn/Comment-Filter@v0 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2012 Cristian Buse 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # VBA-FileTools 2 | 3 | FileTools is a small VBA library that is useful for interacting with the file system. 4 | 5 | Supports **OneDrive/SharePoint/UNC** path conversion to **local** drive path (```GetLocalPath```) and viceversa (```GetRemotePath```) written in collaboration with Guido ([@guwidoe](https://github.com/guwidoe) / [GWD](https://stackoverflow.com/users/12287457/gwd)). See relevant [SO Answer](https://stackoverflow.com/a/73577057/8488913) written by Guido. Many thanks to him! 6 | 7 | ## Installation 8 | 9 | Just import the following code module(s) in your VBA Project: 10 | 11 | * [**LibFileTools.bas**](src/LibFileTools.bas) 12 | * [**UDF_FileTools.bas**](src/UDF_FileTools.bas) (optional - works in MS Excel interface only, with exposed User Defined Functions) 13 | 14 | ## Usage 15 | 16 | A couple of demoes saved in the [Demo](src/Demo/DemoLibFileTools.bas) module. 17 | 18 | Public/Exposed methods: 19 | - BrowseForFiles (Windows only) 20 | - BrowseForFolder (Windows only) 21 | - BuildPath 22 | - ConvertText 23 | - CopyFile 24 | - CopyFolder 25 | - CreateFolder 26 | - DecodeURL 27 | - DeleteFile 28 | - DeleteFolder 29 | - FixFileName 30 | - FixPathSeparators 31 | - GetFileOwner (Windows only) 32 | - GetFiles 33 | - GetFolders 34 | - GetKnownFolderCLSID (Windows only) 35 | - GetKnownFolderPath (Windows only) 36 | - GetLocalPath (covers UNC/OneDrive/SharePoint paths) 37 | - GetRelativePath 38 | - GetRemotePath (covers UNC/OneDrive/SharePoint paths) 39 | - GetSpecialFolderConstant (Mac only) 40 | - GetSpecialFolderDomain (Mac only) 41 | - GetSpecialFolderPath (Mac only) 42 | - IsFile 43 | - IsFolder 44 | - IsFolderEditable 45 | - MoveFile 46 | - MoveFolder 47 | - ParentFolder 48 | - ReadBytes 49 | 50 | Please note that ```GetLocalPath(path)``` can handle only unencoded URL paths. For encoded paths use ```GetLocalPath(DecodeURL(path))```! 51 | 52 | ## Notes 53 | * No extra library references are needed (e.g. Microsoft Scripting Runtime) 54 | * Works in any host Application (Excel, Word, AutoCAD etc.) 55 | * Works on both Windows and Mac. On Mac, 3 of the methods are not available 56 | * Works in both x32 and x64 application environments 57 | 58 | ## License 59 | MIT License 60 | 61 | Copyright (c) 2012 Ion Cristian Buse 62 | 63 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 64 | 65 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 66 | 67 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 68 | -------------------------------------------------------------------------------- /src/Demo/DemoLibFileTools.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DemoLibFileTools" 2 | Option Explicit 3 | 4 | Public Sub DemoMain() 5 | Dim demoFolder As String 6 | ' 7 | 'BrowseForFolder 8 | #If Mac Then 9 | demoFolder = InputBox("Please input a valid folder path! Folder should not be restricted", "Folder Path") 10 | #Else 11 | demoFolder = BrowseForFolder(dialogTitle:="Please select a valid folder! Folder should not be restricted") 12 | #End If 13 | If demoFolder = vbNullString Then Exit Sub 14 | ' 15 | 'A bit of preparation for the demo 16 | If Not IsFolder(demoFolder) Then 17 | Debug.Print "Invalid folder selected. Demo cancelled." 18 | Exit Sub 19 | Else 20 | demoFolder = BuildPath(demoFolder, "Demo") 21 | If Not CreateFolder(demoFolder) Then 22 | Debug.Print "Folder is restricted. Demo cancelled." 23 | Exit Sub 24 | End If 25 | End If 26 | Dim fileNum As Long: fileNum = FreeFile 27 | Dim demoFile As String: demoFile = BuildPath(demoFolder, "demo.txt") 28 | ' 29 | Open demoFile For Append Access Write Lock Write As fileNum 30 | Print #fileNum, "[" & Format(Now, "yyyy-mm-dd hh:nn:ss") & "] Running DemoMain" 31 | Close #fileNum 32 | ' 33 | Dim filePath As String 34 | ' 35 | 'BrowseForFiles 36 | #If Mac Then 37 | #Else 38 | With BrowseForFiles(dialogTitle:="Select any file!", allowMultiFiles:=False) 39 | If .Count <> 0 Then filePath = .Item(1) 40 | End With 41 | If filePath = vbNullString Then Exit Sub 42 | Debug.Print "You have selected: " & filePath 43 | Debug.Print 44 | ' 45 | Dim collFiles As Collection 46 | Dim v As Variant 47 | ' 48 | Do 49 | Set collFiles = BrowseForFiles(dialogTitle:="Select at least 2 files!", allowMultiFiles:=True) 50 | If collFiles.Count = 0 Then Exit Sub 51 | Loop Until collFiles.Count > 1 52 | For Each v In collFiles 53 | Debug.Print "You have selected: " & v 54 | Next v 55 | Debug.Print 56 | #End If 57 | ' 58 | Stop 'You might want to step through code line by line 59 | ' 60 | 'BuildPath 61 | #If Mac Then 62 | Debug.Print "Built path: " & BuildPath("/Users/DemoUser/Desktop/Test", "demo.txt") 63 | Debug.Print "Built path: " & BuildPath("/Users/DemoUser/Desktop/Test/", "demo.txt") 64 | Debug.Print "Built path: " & BuildPath("//Users//DemoUser/Desktop///Test", "demo.txt") 65 | Debug.Print "Built path: " & BuildPath("//Users/DemoUser/Desktop//Test", "Demo/demo.txt") 66 | #Else 67 | Debug.Print "Built path: " & BuildPath("C:\Users\DemoUser\Desktop\Test", "demo.txt") 68 | Debug.Print "Built path: " & BuildPath("C:\Users\DemoUser\Desktop\Test\", "demo.txt") 69 | Debug.Print "Built path: " & BuildPath("C://\Users/\DemoUser\Desktop\\/Test", "demo.txt") 70 | Debug.Print "Built path: " & BuildPath("C:\\Users\DemoUser\Desktop\\Test", "Demo/demo.txt") 71 | #End If 72 | Debug.Print 73 | ' 74 | 'CreateFolder 75 | Dim folderPath As String 76 | ' 77 | folderPath = BuildPath(demoFolder, "/1/2/3/4/5/6/7") 78 | If CreateFolder(folderPath) Then 79 | Debug.Print "Created folder: " & folderPath 80 | Else 81 | Debug.Print "Oops. Cannot create folder: " & folderPath 82 | Exit Sub 83 | End If 84 | Debug.Print 85 | ' 86 | 'CopyFile 87 | Dim i As Long, j As Long 88 | Dim subFolder As String 89 | ' 90 | For i = 1 To 7 91 | subFolder = subFolder & i & PATH_SEPARATOR 92 | For j = 1 To i 93 | filePath = Replace(demoFile, "demo.txt", subFolder & j & ".txt") 94 | If CopyFile(demoFile, filePath) Then 95 | Debug.Print "Copied file: " & filePath 96 | Else 97 | Debug.Print "Oops. Cannot copy file: " & filePath 98 | End If 99 | #If Mac Then 100 | #Else 101 | SetAttr filePath, vbReadOnly + vbHidden + vbSystem 102 | #End If 103 | Next j 104 | Next i 105 | Debug.Print 106 | ' 107 | 'CopyFolder 108 | If CopyFolder(BuildPath(demoFolder, "/1"), BuildPath(demoFolder, "/1.Copy")) Then 109 | Debug.Print "Copied a folder and it's contents" 110 | Else 111 | Debug.Print "Oops. Cannot copy folder" 112 | Exit Sub 113 | End If 114 | Debug.Print 115 | ' 116 | 'DeleteFile 117 | If DeleteFile(demoFile) Then 118 | Debug.Print "Deleted demo file: " & demoFile 119 | Else 120 | Debug.Print "Oops. Cannot delete demo file: " & demoFile 121 | End If 122 | Debug.Print 123 | 'DeleteFolder 124 | ' 125 | If DeleteFolder(BuildPath(demoFolder, "/1.Copy"), True) Then 126 | Debug.Print "Deleted folder and it's contents" 127 | Else 128 | Debug.Print "Oops. Cannot delete folder" 129 | End If 130 | Debug.Print 131 | ' 132 | 'FixFileName 133 | #If Mac Then 134 | Const wrongFileName As String = "The : and the / are forbidden" 135 | #Else 136 | Const wrongFileName As String = "We canot have :*?""<>|\/ and we cannot end in a space or dot ." 137 | #End If 138 | Debug.Print "[" & wrongFileName & "] got fixed to [" & FixFileName(wrongFileName) & "]" 139 | Debug.Print 140 | ' 141 | 'FixPathSeparators 142 | #If Mac Then 143 | Debug.Print "Fixed path: " & FixPathSeparators("/Users/DemoUser/Desktop/Test") 144 | Debug.Print "Fixed path: " & FixPathSeparators("/Users/DemoUser/Desktop/Test/") 145 | Debug.Print "Fixed path: " & FixPathSeparators("//Users//DemoUser/Desktop///Test") 146 | Debug.Print "Fixed path: " & FixPathSeparators("//Users/DemoUser/Desktop//Test") 147 | #Else 148 | Debug.Print "Fixed path: " & FixPathSeparators("C:\Users\DemoUser\Desktop\Test") 149 | Debug.Print "Fixed path: " & FixPathSeparators("C:\Users\DemoUser\Desktop\Test\") 150 | Debug.Print "Fixed path: " & FixPathSeparators("C://\Users/\DemoUser\Desktop\\/Test") 151 | Debug.Print "Fixed path: " & FixPathSeparators("C:\\Users\DemoUser\Desktop\\Test") 152 | #End If 153 | Debug.Print 154 | ' 155 | 'GetFileOwner 156 | #If Mac Then 157 | #Else 158 | filePath = BuildPath(demoFolder, "/1/2/3/2.txt") 159 | Debug.Print "The owner of: " & filePath & " is " & GetFileOwner(filePath) 160 | Debug.Print 161 | #End If 162 | ' 163 | Dim f As Variant 164 | ' 165 | 'GetFiles 166 | folderPath = BuildPath(demoFolder, "/1/2/3/4/5") 167 | Debug.Print "The files in: " & folderPath & " are:" 168 | For Each f In GetFiles(folderPath, True, True, True) 169 | Debug.Print f 170 | Next f 171 | Debug.Print 172 | ' 173 | 'GetFolders 174 | Debug.Print "The folders in: " & demoFolder & " are:" 175 | For Each f In GetFolders(demoFolder, True, True, True) 176 | Debug.Print f 177 | Next f 178 | Debug.Print 179 | ' 180 | 'GetLocalPath 181 | 'GetUNCPath 182 | #If Mac Then 183 | #Else 184 | With BrowseForFiles(dialogTitle:="Please select a file on a mapped network drive", allowMultiFiles:=False) 185 | If .Count > 0 Then 186 | filePath = .Item(1) 187 | Debug.Print "Local path is: " & GetLocalPath(filePath) 188 | Debug.Print "Remote path is: " & GetRemotePath(filePath) 189 | Debug.Print 190 | End If 191 | End With 192 | #End If 193 | ' 194 | 'GetPathSeparator 195 | Debug.Print "The path separator is: " & PATH_SEPARATOR 196 | Debug.Print 197 | ' 198 | 'IsFile 199 | filePath = demoFile 200 | Debug.Print "This is " & IIf(IsFile(filePath), vbNullString, "not ") & "a file: " & filePath 201 | filePath = GetFiles(demoFolder, True, True, True).Item(15) 202 | Debug.Print "This is " & IIf(IsFile(filePath), vbNullString, "not ") & "a file: " & filePath 203 | Debug.Print 204 | ' 205 | 'IsFolder 206 | folderPath = GetFolders(demoFolder, True, True, True).Item(5) 207 | Debug.Print "This is " & IIf(IsFolder(folderPath), vbNullString, "not ") & "a folder: " & folderPath 208 | folderPath = "Not a folder" 209 | Debug.Print "This is " & IIf(IsFolder(folderPath), vbNullString, "not ") & "a folder: " & folderPath 210 | Debug.Print 211 | ' 212 | 'MoveFile 213 | filePath = GetFiles(demoFolder, True, True, True).Item(10) 214 | If MoveFile(filePath, demoFile) Then 215 | Debug.Print "Moved: " & filePath & " to: " & demoFile 216 | Else 217 | Debug.Print "Oops. Cannot move file" 218 | End If 219 | Debug.Print 220 | ' 221 | 'MoveFolder 222 | If MoveFolder(BuildPath(demoFolder, "/1/2/3/4"), BuildPath(demoFolder, "////M")) Then 223 | Debug.Print "Moved a folder and it's contents" 224 | Else 225 | Debug.Print "Oops. Failed to move folder" 226 | End If 227 | Debug.Print 228 | ' 229 | Debug.Print "Finished Demo" 230 | DeleteFolder folderPath:=demoFolder, deleteContents:=True 231 | End Sub 232 | -------------------------------------------------------------------------------- /src/LibFileTools.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "LibFileTools" 2 | '''============================================================================= 3 | ''' VBA FileTools 4 | ''' --------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-FileTools 6 | ''' --------------------------------------------- 7 | ''' MIT License 8 | ''' 9 | ''' Copyright (c) 2012 Ion Cristian Buse 10 | ''' 11 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 12 | ''' of this software and associated documentation files (the "Software"), to 13 | ''' deal in the Software without restriction, including without limitation the 14 | ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 15 | ''' sell copies of the Software, and to permit persons to whom the Software is 16 | ''' furnished to do so, subject to the following conditions: 17 | ''' 18 | ''' The above copyright notice and this permission notice shall be included in 19 | ''' all copies or substantial portions of the Software. 20 | ''' 21 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 27 | ''' IN THE SOFTWARE. 28 | '''============================================================================= 29 | 30 | '******************************************************************************* 31 | '' Functions in this library module allow easy file system manipulation in VBA 32 | '' regardless of: 33 | '' - the host Application (Excel, Word, AutoCAD etc.) 34 | '' - the operating system (Mac, Windows) 35 | '' - application environment (x32, x64) 36 | '' No extra library references are needed (e.g. Microsoft Scripting Runtime) 37 | '' 38 | '' Public/Exposed methods: 39 | '' - BrowseForFiles (Windows only) 40 | '' - BrowseForFolder (Windows only) 41 | '' - BuildPath 42 | '' - ConvertText 43 | '' - CopyFile 44 | '' - CopyFolder 45 | '' - CreateFolder 46 | '' - DecodeURL 47 | '' - DeleteFile 48 | '' - DeleteFolder 49 | '' - FixFileName 50 | '' - FixPathSeparators 51 | '' - GetFileOwner (Windows only) 52 | '' - GetFiles 53 | '' - GetFolders 54 | '' - GetKnownFolderCLSID (Windows only) 55 | '' - GetKnownFolderPath (Windows only) 56 | '' - GetLocalPath 57 | '' - GetRelativePath 58 | '' - GetRemotePath 59 | '' - GetSpecialFolderConstant (Mac only) 60 | '' - GetSpecialFolderDomain (Mac only) 61 | '' - GetSpecialFolderPath (Mac only) 62 | '' - IsFile 63 | '' - IsFolder 64 | '' - IsFolderEditable 65 | '' - MoveFile 66 | '' - MoveFolder 67 | '' - ParentFolder 68 | '' - ReadBytes 69 | '******************************************************************************* 70 | 71 | Option Explicit 72 | Option Private Module 73 | 74 | #Const Windows = (Mac = 0) 75 | 76 | #If Mac Then 77 | #If VBA7 Then 'https://developer.apple.com/library/archive/documentation/System/Conceptual/ManPages_iPhoneOS/man3/iconv.3.html 78 | Private Declare PtrSafe Function iconv Lib "/usr/lib/libiconv.dylib" (ByVal cd As LongPtr, ByRef inBuf As LongPtr, ByRef inBytesLeft As LongPtr, ByRef outBuf As LongPtr, ByRef outBytesLeft As LongPtr) As LongPtr 79 | Private Declare PtrSafe Function iconv_open Lib "/usr/lib/libiconv.dylib" (ByVal toCode As LongPtr, ByVal fromCode As LongPtr) As LongPtr 80 | Private Declare PtrSafe Function iconv_close Lib "/usr/lib/libiconv.dylib" (ByVal cd As LongPtr) As Long 81 | #Else 82 | Private Declare Function iconv Lib "/usr/lib/libiconv.dylib" (ByVal cd As Long, ByRef inBuf As Long, ByRef inBytesLeft As Long, ByRef outBuf As Long, ByRef outBytesLeft As Long) As Long 83 | Private Declare Function iconv_open Lib "/usr/lib/libiconv.dylib" (ByVal toCode As Long, ByVal fromCode As Long) As Long 84 | Private Declare Function iconv_close Lib "/usr/lib/libiconv.dylib" (ByVal cd As Long) As Long 85 | #End If 86 | #Else 87 | #If VBA7 Then 88 | Private Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long 89 | Private Declare PtrSafe Function GetOpenFileNameW Lib "comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long 90 | Private Declare PtrSafe Function CopyFileW Lib "kernel32" (ByVal lpExistingFileName As LongPtr, ByVal lpNewFileName As LongPtr, ByVal bFailIfExists As Long) As Long 91 | Private Declare PtrSafe Function DeleteFileW Lib "kernel32" (ByVal lpFileName As LongPtr) As Long 92 | Private Declare PtrSafe Function RemoveDirectoryW Lib "kernel32" (ByVal lpPathName As LongPtr) As Long 93 | Private Declare PtrSafe Function GetFileSecurity Lib "advapi32.dll" Alias "GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, ByVal nLength As Long, lpnLengthNeeded As Long) As Long 94 | Private Declare PtrSafe Function GetSecurityDescriptorOwner Lib "advapi32.dll" (pSecurityDescriptor As Byte, pOwner As LongPtr, lpbOwnerDefaulted As LongPtr) As Long 95 | Private Declare PtrSafe Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As LongPtr, ByVal Name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As LongPtr) As Long 96 | Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal codePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As LongPtr, ByVal cbMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long 97 | Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal codePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, ByVal lpMultiByteStr As LongPtr, ByVal cbMultiByte As Long, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long 98 | Private Declare PtrSafe Function SHGetKnownFolderPath Lib "shell32" (ByRef rfID As GUID, ByVal dwFlags As Long, ByVal hToken As Long, ByRef pszPath As LongPtr) As Long 99 | Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpszGuid As LongPtr, ByRef pGuid As GUID) As Long 100 | Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long 101 | Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal hMem As LongPtr) 102 | Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr) 103 | #Else 104 | Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long 105 | Private Declare Function GetOpenFileNameW Lib "comdlg32.dll" (pOpenfilename As OPENFILENAME) As Long 106 | Private Declare Function CopyFileW Lib "kernel32" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long, ByVal bFailIfExists As Long) As Long 107 | Private Declare Function DeleteFileW Lib "kernel32" (ByVal lpFileName As Long) As Long 108 | Private Declare Function RemoveDirectoryW Lib "kernel32" (ByVal lpPathName As Long) As Long 109 | Private Declare Function GetFileSecurity Lib "advapi32.dll" Alias "GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, ByVal nLength As Long, lpnLengthNeeded As Long) As Long 110 | Private Declare Function GetSecurityDescriptorOwner Lib "advapi32.dll" (pSecurityDescriptor As Byte, pOwner As Long, lpbOwnerDefaulted As Long) As Long 111 | Private Declare Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As Long, ByVal Name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long 112 | Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal codePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long 113 | Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long 114 | Private Declare Function SHGetKnownFolderPath Lib "shell32" (rfID As Any, ByVal dwFlags As Long, ByVal hToken As Long, ppszPath As Long) As Long 115 | Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszGuid As Long, pGuid As Any) As Long 116 | Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long 117 | Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long) 118 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) 119 | #End If 120 | #End If 121 | 122 | #If VBA7 = 0 Then 123 | Private Enum LongPtr 124 | [_] 125 | End Enum 126 | #End If 127 | 128 | Public Enum PageCode 129 | [_pcCount] = 5 130 | codeUTF8 = 65001 131 | codeUTF16LE = 1200 132 | codeUTF16BE = 1201 133 | #If Mac Then 134 | codeUTF32LE = 12000 135 | codeUTF32BE = 12001 136 | #End If 137 | End Enum 138 | 139 | #If Mac Then 140 | Public Enum SpecialFolderConstant 'See 'GetSpecialFolderConstant' 141 | sfc_ApplicationSupport 142 | [_minSFC] = sfc_ApplicationSupport 143 | sfc_ApplicationsFolder 144 | sfc_Desktop 145 | sfc_DesktopPicturesFolder 146 | sfc_DocumentsFolder 147 | sfc_DownloadsFolder 148 | sfc_FavoritesFolder 149 | sfc_FolderActionScripts 150 | sfc_Fonts 151 | sfc_Help 152 | sfc_HomeFolder 153 | sfc_InternetPlugins 154 | sfc_KeychainFolder 155 | sfc_LibraryFolder 156 | sfc_ModemScripts 157 | sfc_MoviesFolder 158 | sfc_MusicFolder 159 | sfc_PicturesFolder 160 | sfc_Preferences 161 | sfc_PrinterDescriptions 162 | sfc_PublicFolder 163 | sfc_ScriptingAdditions 164 | sfc_ScriptsFolder 165 | sfc_ServicesFolder 166 | sfc_SharedDocuments 167 | sfc_SharedLibraries 168 | sfc_SitesFolder 169 | sfc_StartupDisk 170 | sfc_StartupItems 171 | sfc_SystemFolder 172 | sfc_SystemPreferences 173 | sfc_TemporaryItems 174 | sfc_Trash 175 | sfc_UsersFolder 176 | sfc_UtilitiesFolder 177 | sfc_WorkflowsFolder 178 | ' 179 | 'Classic domain only 180 | sfc_AppleMenu 181 | sfc_ControlPanels 182 | sfc_ControlStripModules 183 | sfc_Extensions 184 | sfc_LauncherItemsFolder 185 | sfc_PrinterDrivers 186 | sfc_Printmonitor 187 | sfc_ShutdownFolder 188 | sfc_SpeakableItems 189 | sfc_Stationery 190 | sfc_Voices 191 | [_maxSFC] = sfc_Voices 192 | End Enum 193 | Public Enum SpecialFolderDomain 'See 'GetSpecialFolderDomain 194 | [_sfdNone] = 0 195 | [_minSFD] = [_sfdNone] 196 | sfd_System 197 | sfd_Local 198 | sfd_Network 199 | sfd_User 200 | sfd_Classic 201 | [_maxSFD] = sfd_Classic 202 | End Enum 203 | #Else 204 | Public Enum KnownFolderID 'See 'GetKnownFolderCLSID' method 205 | kfID_AccountPictures = 0 206 | [_minKfID] = kfID_AccountPictures 207 | kfID_AddNewPrograms 208 | kfID_AdminTools 209 | kfID_AllAppMods 210 | kfID_AppCaptures 211 | kfID_AppDataDesktop 212 | kfID_AppDataDocuments 213 | kfID_AppDataFavorites 214 | kfID_AppDataProgramData 215 | kfID_ApplicationShortcuts 216 | kfID_AppsFolder 217 | kfID_AppUpdates 218 | kfID_CameraRoll 219 | kfID_CameraRollLibrary 220 | kfID_CDBurning 221 | kfID_ChangeRemovePrograms 222 | kfID_CommonAdminTools 223 | kfID_CommonOEMLinks 224 | kfID_CommonPrograms 225 | kfID_CommonStartMenu 226 | kfID_CommonStartMenuPlaces 227 | kfID_CommonStartup 228 | kfID_CommonTemplates 229 | kfID_ComputerFolder 230 | kfID_ConflictFolder 231 | kfID_ConnectionsFolder 232 | kfID_Contacts 233 | kfID_ControlPanelFolder 234 | kfID_Cookies 235 | kfID_CurrentAppMods 236 | kfID_Desktop 237 | kfID_DevelopmentFiles 238 | kfID_Device 239 | kfID_DeviceMetadataStore 240 | kfID_Documents 241 | kfID_DocumentsLibrary 242 | kfID_Downloads 243 | kfID_Favorites 244 | kfID_Fonts 245 | kfID_Games 246 | kfID_GameTasks 247 | kfID_History 248 | kfID_HomeGroup 249 | kfID_HomeGroupCurrentUser 250 | kfID_ImplicitAppShortcuts 251 | kfID_InternetCache 252 | kfID_InternetFolder 253 | kfID_Libraries 254 | kfID_Links 255 | kfID_LocalAppData 256 | kfID_LocalAppDataLow 257 | kfID_LocalDocuments 258 | kfID_LocalDownloads 259 | kfID_LocalizedResourcesDir 260 | kfID_LocalMusic 261 | kfID_LocalPictures 262 | kfID_LocalStorage 263 | kfID_LocalVideos 264 | kfID_Music 265 | kfID_MusicLibrary 266 | kfID_NetHood 267 | kfID_NetworkFolder 268 | kfID_Objects3D 269 | kfID_OneDrive 270 | kfID_OriginalImages 271 | kfID_PhotoAlbums 272 | kfID_Pictures 273 | kfID_PicturesLibrary 274 | kfID_Playlists 275 | kfID_PrintersFolder 276 | kfID_PrintHood 277 | kfID_Profile 278 | kfID_ProgramData 279 | kfID_ProgramFiles 280 | kfID_ProgramFilesCommon 281 | kfID_ProgramFilesCommonX64 282 | kfID_ProgramFilesCommonX86 283 | kfID_ProgramFilesX64 284 | kfID_ProgramFilesX86 285 | kfID_Programs 286 | kfID_Public 287 | kfID_PublicDesktop 288 | kfID_PublicDocuments 289 | kfID_PublicDownloads 290 | kfID_PublicGameTasks 291 | kfID_PublicLibraries 292 | kfID_PublicMusic 293 | kfID_PublicPictures 294 | kfID_PublicRingtones 295 | kfID_PublicUserTiles 296 | kfID_PublicVideos 297 | kfID_QuickLaunch 298 | kfID_Recent 299 | kfID_RecordedCalls 300 | kfID_RecordedTVLibrary 301 | kfID_RecycleBinFolder 302 | kfID_ResourceDir 303 | kfID_RetailDemo 304 | kfID_Ringtones 305 | kfID_RoamedTileImages 306 | kfID_RoamingAppData 307 | kfID_RoamingTiles 308 | kfID_SampleMusic 309 | kfID_SamplePictures 310 | kfID_SamplePlaylists 311 | kfID_SampleVideos 312 | kfID_SavedGames 313 | kfID_SavedPictures 314 | kfID_SavedPicturesLibrary 315 | kfID_SavedSearches 316 | kfID_Screenshots 317 | kfID_SEARCH_CSC 318 | kfID_SEARCH_MAPI 319 | kfID_SearchHistory 320 | kfID_SearchHome 321 | kfID_SearchTemplates 322 | kfID_SendTo 323 | kfID_SidebarDefaultParts 324 | kfID_SidebarParts 325 | kfID_SkyDrive 326 | kfID_SkyDriveCameraRoll 327 | kfID_SkyDriveDocuments 328 | kfID_SkyDriveMusic 329 | kfID_SkyDrivePictures 330 | kfID_StartMenu 331 | kfID_StartMenuAllPrograms 332 | kfID_Startup 333 | kfID_SyncManagerFolder 334 | kfID_SyncResultsFolder 335 | kfID_SyncSetupFolder 336 | kfID_System 337 | kfID_SystemX86 338 | kfID_Templates 339 | kfID_UserPinned 340 | kfID_UserProfiles 341 | kfID_UserProgramFiles 342 | kfID_UserProgramFilesCommon 343 | kfID_UsersFiles 344 | kfID_UsersLibraries 345 | kfID_Videos 346 | kfID_VideosLibrary 347 | kfID_Windows 348 | [_maxKfID] = kfID_Windows 349 | End Enum 350 | #End If 351 | 352 | Private Type DRIVE_INFO 353 | driveName As String 354 | driveLetter As String 355 | fileSystem As String 356 | shareName As String 357 | End Type 358 | 359 | #If Windows Then 360 | Private Type GUID 361 | data1 As Long 362 | data2 As Integer 363 | data3 As Integer 364 | data4(0 To 7) As Byte 365 | End Type 366 | ' 367 | 'https://docs.microsoft.com/en-gb/windows/win32/api/commdlg/ns-commdlg-openfilenamea 368 | Private Type OPENFILENAME 369 | lStructSize As Long 370 | hwndOwner As LongPtr 371 | hInstance As LongPtr 372 | lpstrFilter As LongPtr 373 | lpstrCustomFilter As LongPtr 374 | nMaxCustFilter As Long 375 | nFilterIndex As Long 376 | lpstrFile As LongPtr 377 | nMaxFile As Long 378 | lpstrFileTitle As LongPtr 379 | nMaxFileTitle As Long 380 | lpstrInitialDir As LongPtr 381 | lpstrTitle As LongPtr 382 | flags As Long 383 | nFileOffset As Integer 384 | nFileExtension As Integer 385 | lpstrDefExt As LongPtr 386 | lCustData As LongPtr 387 | lpfnHook As LongPtr 388 | lpTemplateName As LongPtr 389 | pvReserved As LongPtr 390 | dwReserved As Long 391 | flagsEx As Long 392 | End Type 393 | #End If 394 | 395 | Private Type ONEDRIVE_PROVIDER 396 | webPath As String 397 | mountPoint As String 398 | isBusiness As Boolean 399 | isMain As Boolean 400 | accountIndex As Long 401 | baseMount As String 402 | syncID As String 403 | #If Mac Then 404 | syncDir As String 405 | #End If 406 | End Type 407 | Private Type ONEDRIVE_PROVIDERS 408 | arr() As ONEDRIVE_PROVIDER 409 | pCount As Long 410 | isSet As Boolean 411 | lastCacheUpdate As Date 412 | End Type 413 | 414 | Private Type ONEDRIVE_ACCOUNT_INFO 415 | accountIndex As Long 416 | accountName As String 417 | cID As String 418 | clientPath As String 419 | datPath As String 420 | dbPath As String 421 | folderPath As String 422 | globalPath As String 423 | groupPath As String 424 | iniDateTime As Date 425 | iniPath As String 426 | isPersonal As Boolean 427 | isValid As Boolean 428 | hasDatFile As Boolean 429 | End Type 430 | Private Type ONEDRIVE_ACCOUNTS_INFO 431 | arr() As ONEDRIVE_ACCOUNT_INFO 432 | pCount As Long 433 | isSet As Boolean 434 | End Type 435 | 436 | Private Type DirInfo 437 | dirID As String 438 | parentID As String 439 | dirName As String 440 | isNameASCII As Boolean 441 | End Type 442 | Private Type DirsInfo 443 | idToIndex As Collection 444 | arrDirs() As DirInfo 445 | dirCount As Long 446 | dirUBound As Long 447 | End Type 448 | 449 | #If Mac Then 450 | Public Const PATH_SEPARATOR = "/" 451 | #Else 452 | Public Const PATH_SEPARATOR = "\" 453 | #End If 454 | 455 | Private Const vbErrInvalidProcedureCall As Long = 5 456 | Private Const vbErrInternalError As Long = 51 457 | Private Const vbErrPathFileAccessError As Long = 75 458 | Private Const vbErrPathNotFound As Long = 76 459 | Private Const vbErrInvalidFormatInResourceFile As Long = 325 460 | Private Const vbErrComponentNotRegistered As Long = 336 461 | 462 | Private m_providers As ONEDRIVE_PROVIDERS 463 | #If Mac Then 464 | Private m_conversionDescriptors As New Collection 465 | #End If 466 | 467 | '******************************************************************************* 468 | 'Returns a Collection of file paths by using a FilePicker FileDialog 469 | 'Always returns an instantiated Collection 470 | ' 471 | 'More than one file extension may be specified in the 'filterExtensions' param 472 | ' and each must be separated by a semi-colon. For example: "*.txt;*.csv". 473 | ' Spaces will be ignored 474 | '******************************************************************************* 475 | Public Function BrowseForFiles(Optional ByRef initialPath As String _ 476 | , Optional ByRef dialogTitle As String _ 477 | , Optional ByRef filterDesc As String _ 478 | , Optional ByRef filterExtensions As String _ 479 | , Optional ByVal allowMultiFiles As Boolean = True) As Collection 480 | 'msoFileDialogFilePicker = 3 - only available for some Microsoft apps 481 | Const dialogTypeFilePicker As Long = 3 482 | Const actionButton As Long = -1 483 | Dim filePicker As Object 484 | Dim app As Object: Set app = Application 'Late-binded for compatibility 485 | ' 486 | On Error Resume Next 487 | Set filePicker = app.FileDialog(dialogTypeFilePicker) 488 | On Error GoTo 0 489 | ' 490 | If filePicker Is Nothing Then 491 | #If Mac Then 492 | 'Not implemented 493 | 'Seems achievable via script: 494 | ' - https://stackoverflow.com/a/15546518/8488913 495 | ' - https://stackoverflow.com/a/37411960/8488913 496 | #Else 497 | Set BrowseForFiles = BrowseFilesAPI(initialPath, dialogTitle, filterDesc _ 498 | , filterExtensions, allowMultiFiles) 499 | #End If 500 | Exit Function 501 | End If 502 | ' 503 | With filePicker 504 | If LenB(dialogTitle) > 0 Then .Title = dialogTitle 505 | If LenB(initialPath) > 0 Then .InitialFileName = initialPath 506 | .allowMultiSelect = allowMultiFiles 507 | .filters.Clear 508 | If LenB(filterExtensions) > 0 Then 509 | On Error Resume Next 510 | .filters.Add filterDesc, filterExtensions 511 | On Error GoTo 0 512 | End If 513 | If .filters.Count = 0 Then .filters.Add "All Files", "*.*" 514 | ' 515 | Set BrowseForFiles = New Collection 516 | If .Show = actionButton Then 517 | Dim v As Variant 518 | ' 519 | For Each v In .SelectedItems 520 | BrowseForFiles.Add v 521 | Next v 522 | End If 523 | End With 524 | End Function 525 | 526 | '******************************************************************************* 527 | 'Returns a Collection of file paths by creating an Open dialog box that lets the 528 | ' user specify the drive, directory, and the name of the file(s) 529 | '******************************************************************************* 530 | #If Windows Then 531 | Private Function BrowseFilesAPI(ByRef initialPath As String _ 532 | , ByRef dialogTitle As String _ 533 | , ByRef filterDesc As String _ 534 | , ByRef filterExtensions As String _ 535 | , ByVal allowMultiFiles As Boolean) As Collection 536 | Dim ofName As OPENFILENAME 537 | Dim resultPaths As New Collection 538 | Dim buffFiles As String 539 | Dim buffFilter As String 540 | Dim temp As String 541 | ' 542 | With ofName 543 | On Error Resume Next 544 | Dim app As Object: Set app = Application 545 | .hwndOwner = app.Hwnd 546 | On Error GoTo 0 547 | ' 548 | .lStructSize = LenB(ofName) 549 | If LenB(filterExtensions) = 0 Then 550 | buffFilter = "All Files (*.*)" & vbNullChar & "*.*" 551 | Else 552 | temp = Replace(filterExtensions, ",", ";") 553 | buffFilter = filterDesc & " (" & temp & ")" & vbNullChar & temp 554 | End If 555 | buffFilter = buffFilter & vbNullChar & vbNullChar 556 | .lpstrFilter = StrPtr(buffFilter) 557 | ' 558 | .nMaxFile = &H100000 559 | buffFiles = VBA.Space$(.nMaxFile) 560 | .lpstrFile = StrPtr(buffFiles) 561 | .lpstrInitialDir = StrPtr(initialPath) 562 | .lpstrTitle = StrPtr(dialogTitle) 563 | ' 564 | Const OFN_HIDEREADONLY As Long = &H4& 565 | Const OFN_ALLOWMULTISELECT As Long = &H200& 566 | Const OFN_PATHMUSTEXIST As Long = &H800& 567 | Const OFN_FILEMUSTEXIST As Long = &H1000& 568 | Const OFN_EXPLORER As Long = &H80000 569 | ' 570 | .flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST 571 | If allowMultiFiles Then 572 | .flags = .flags Or OFN_ALLOWMULTISELECT Or OFN_EXPLORER 573 | End If 574 | End With 575 | ' 576 | Do 577 | Const FNERR_BUFFERTOOSMALL As Long = &H3003& 578 | Dim mustRetry As Boolean: mustRetry = False 579 | Dim i As Long 580 | Dim j As Long 581 | ' 582 | If GetOpenFileNameW(ofName) Then 583 | i = InStr(1, buffFiles, vbNullChar) 584 | temp = Left$(buffFiles, i - 1) 585 | ' 586 | If allowMultiFiles Then 587 | j = InStr(i + 1, buffFiles, vbNullChar) 588 | If j = i + 1 Then 'Single file selected 589 | resultPaths.Add temp 590 | Else 591 | temp = BuildPath(temp, vbNullString) 'Parent folder 592 | Do 593 | resultPaths.Add temp & Mid$(buffFiles, i + 1, j - i) 594 | i = j 595 | j = InStr(i + 1, buffFiles, vbNullChar) 596 | Loop Until j = i + 1 597 | End If 598 | Else 599 | resultPaths.Add temp 600 | End If 601 | ElseIf CommDlgExtendedError() = FNERR_BUFFERTOOSMALL Then 602 | Dim b() As Byte: b = LeftB$(buffFiles, 4) 603 | ' 604 | If b(3) And &H80 Then 605 | mustRetry = (MsgBox("Try selecting fewer files" _ 606 | , vbExclamation + vbRetryCancel _ 607 | , "Insufficient memory") = vbRetry) 608 | Else 609 | With ofName 610 | .nMaxFile = b(3) 611 | For i = 2 To 0 Step -1 612 | .nMaxFile = .nMaxFile * &H100& + b(i) 613 | Next i 614 | buffFiles = VBA.Space$(.nMaxFile) 615 | .lpstrFile = StrPtr(buffFiles) 616 | End With 617 | MsgBox "Did not expect so many files. Please select again!" _ 618 | , vbInformation, "Repeat selection" 619 | mustRetry = True 620 | End If 621 | End If 622 | Loop Until Not mustRetry 623 | Set BrowseFilesAPI = resultPaths 624 | End Function 625 | #End If 626 | 627 | '******************************************************************************* 628 | 'Returns a folder path by using a FolderPicker FileDialog 629 | '******************************************************************************* 630 | Public Function BrowseForFolder(Optional ByRef initialPath As String _ 631 | , Optional ByRef dialogTitle As String) As String 632 | #If Mac Then 633 | 'If user has not accesss [initialPath] previously, will be prompted by 634 | 'Mac OS to Grant permission to directory 635 | If LenB(initialPath) > 0 Then 636 | If Not Right(initialPath, 1) = PATH_SEPARATOR Then 637 | initialPath = initialPath & PATH_SEPARATOR 638 | End If 639 | Dir initialPath, Attributes:=vbDirectory 640 | End If 641 | Dim retPath 642 | If LenB(dialogTitle) = 0 Then dialogTitle = "Choose Foldler" 643 | retPath = MacScript("choose folder with prompt """ & dialogTitle & """ as string") 644 | If Len(retPath) > 0 Then 645 | retPath = MacScript("POSIX path of """ & retPath & """") 646 | If LenB(retPath) > 0 Then 647 | BrowseForFolder = retPath 648 | End If 649 | End If 650 | #ElseIf Windows Then 651 | 'In case reference to Microsoft Office X.XX Object Library is missing 652 | Const dialogTypeFolderPicker As Long = 4 'msoFileDialogFolderPicker 653 | Const actionButton As Long = -1 654 | ' 655 | With Application.FileDialog(dialogTypeFolderPicker) 656 | If LenB(dialogTitle) > 0 Then .Title = dialogTitle 657 | If LenB(initialPath) > 0 Then .InitialFileName = BuildPath(initialPath, PATH_SEPARATOR) 658 | If LenB(.InitialFileName) = 0 Then 659 | Dim app As Object: Set app = Application 'Needs to be late-binded 660 | Select Case app.Name 661 | Case "Microsoft Excel": .InitialFileName = GetLocalPath(app.ThisWorkbook.Path, , True) 662 | Case "Microsoft Word": .InitialFileName = GetLocalPath(app.ThisDocument.Path, , True) 663 | End Select 664 | End If 665 | If .Show = actionButton Then 666 | .InitialFileName = .SelectedItems.Item(1) 667 | BrowseForFolder = .InitialFileName 668 | End If 669 | End With 670 | #End If 671 | End Function 672 | 673 | '******************************************************************************* 674 | 'Combines a folder path with a file/folder name or an incomplete path (ex. \a\b) 675 | '******************************************************************************* 676 | Public Function BuildPath(ParamArray PathComponents() As Variant) As String 677 | BuildPath = FixPathSeparators(Join(PathComponents, PATH_SEPARATOR)) 678 | End Function 679 | 680 | '******************************************************************************* 681 | 'Converts a text between 2 page codes 682 | '******************************************************************************* 683 | #If Mac Then 684 | Public Function ConvertText(ByRef textToConvert As String _ 685 | , ByVal toCode As PageCode _ 686 | , ByVal fromCode As PageCode _ 687 | , Optional ByVal persistDescriptor As Boolean = False) As String 688 | #Else 689 | Public Function ConvertText(ByRef textToConvert As String _ 690 | , ByVal toCode As PageCode _ 691 | , ByVal fromCode As PageCode) As String 692 | #End If 693 | If toCode = fromCode Then 694 | ConvertText = textToConvert 695 | Exit Function 696 | End If 697 | #If Mac Then 698 | Dim inBytesLeft As LongPtr: inBytesLeft = LenB(textToConvert) 699 | Dim outBytesLeft As LongPtr: outBytesLeft = inBytesLeft * 4 700 | Dim buffer As String: buffer = Space$(CLng(inBytesLeft) * 2) 701 | Dim inBuf As LongPtr: inBuf = StrPtr(textToConvert) 702 | Dim outBuf As LongPtr: outBuf = StrPtr(buffer) 703 | Dim cd As LongPtr 704 | Dim cdKey As String: cdKey = fromCode & "_" & toCode 705 | Dim cdFound As Boolean 706 | ' 707 | On Error Resume Next 708 | cd = m_conversionDescriptors(cdKey) 709 | cdFound = (cd <> 0) 710 | On Error GoTo 0 711 | If Not cdFound Then 712 | cd = iconv_open(StrPtr(PageCodeToText(toCode)) _ 713 | , StrPtr(PageCodeToText(fromCode))) 714 | If persistDescriptor Then m_conversionDescriptors.Add cd, cdKey 715 | End If 716 | If iconv(cd, inBuf, inBytesLeft, outBuf, outBytesLeft) <> -1 Then 717 | ConvertText = LeftB$(buffer, LenB(buffer) - CLng(outBytesLeft)) 718 | End If 719 | If Not (cdFound Or persistDescriptor) Then iconv_close cd 720 | #Else 721 | If toCode = codeUTF16LE Then 722 | ConvertText = EncodeToUTF16LE(textToConvert, fromCode) 723 | ElseIf fromCode = codeUTF16LE Then 724 | ConvertText = EncodeFromUTF16LE(textToConvert, toCode) 725 | Else 726 | ConvertText = EncodeFromUTF16LE( _ 727 | EncodeToUTF16LE(textToConvert, fromCode), toCode) 728 | End If 729 | #End If 730 | End Function 731 | #If Mac Then 732 | Public Sub ClearConversionDescriptors() 733 | If m_conversionDescriptors.Count = 0 Then Exit Sub 734 | Dim v As Variant 735 | ' 736 | For Each v In m_conversionDescriptors 737 | iconv_close v 738 | Next v 739 | Set m_conversionDescriptors = Nothing 740 | End Sub 741 | Private Function PageCodeToText(ByVal pc As PageCode) As String 742 | Dim result As String 743 | Select Case pc 744 | Case codeUTF8: result = "UTF-8" 745 | Case codeUTF16LE: result = "UTF-16LE" 746 | Case codeUTF16BE: result = "UTF-16BE" 747 | Case codeUTF32LE: result = "UTF-32LE" 748 | Case codeUTF32BE: result = "UTF-32BE" 749 | End Select 750 | PageCodeToText = StrConv(result, vbFromUnicode) 751 | End Function 752 | #Else 753 | Private Function EncodeToUTF16LE(ByRef textToConvert As String _ 754 | , ByVal fromCode As PageCode) As String 755 | Dim charCount As Long 756 | charCount = MultiByteToWideChar(fromCode, 0, StrPtr(textToConvert) _ 757 | , LenB(textToConvert), 0, 0) 758 | If charCount = 0 Then Exit Function 759 | 760 | EncodeToUTF16LE = Space$(charCount) 761 | MultiByteToWideChar fromCode, 0, StrPtr(textToConvert) _ 762 | , LenB(textToConvert), StrPtr(EncodeToUTF16LE), charCount 763 | End Function 764 | Private Function EncodeFromUTF16LE(ByRef textToConvert As String _ 765 | , ByVal toCode As PageCode) As String 766 | Dim byteCount As Long 767 | byteCount = WideCharToMultiByte(toCode, 0, StrPtr(textToConvert) _ 768 | , Len(textToConvert), 0, 0, 0, 0) 769 | If byteCount = 0 Then Exit Function 770 | ' 771 | EncodeFromUTF16LE = Space$((byteCount + 1) \ 2) 772 | If byteCount Mod 2 = 1 Then 773 | EncodeFromUTF16LE = LeftB$(EncodeFromUTF16LE, byteCount) 774 | End If 775 | WideCharToMultiByte toCode, 0, StrPtr(textToConvert), Len(textToConvert) _ 776 | , StrPtr(EncodeFromUTF16LE), byteCount, 0, 0 777 | End Function 778 | #End If 779 | 780 | '******************************************************************************* 781 | 'Copies a file. Overwrites existing files unless 'failIfExists' is set to True 782 | 'Note that VBA.FileCopy does not copy opened files on Windows but it does on Mac 783 | 'If the destination file already exists and 'failIfExists' is set to False 784 | ' then this method must be able to overwrite the destination file. Rather than 785 | ' failing and then trying again with attribute set to vbNormal this method 786 | ' sets the attribute for the destination path to vbNormal before copying. 787 | ' This is slightly slower than just copying directly but far outperforms two 788 | ' copy operations in the case where the first one fails and the second one is 789 | ' done after setting the destination file attribute to vbNormal. 790 | '******************************************************************************* 791 | Public Function CopyFile(ByRef sourcePath As String _ 792 | , ByRef destinationPath As String _ 793 | , Optional ByVal failIfExists As Boolean = False) As Boolean 794 | If LenB(sourcePath) = 0 Then Exit Function 795 | If LenB(destinationPath) = 0 Then Exit Function 796 | ' 797 | #If Mac Then 798 | If failIfExists Then If IsFile(destinationPath) Then Exit Function 799 | ' 800 | On Error Resume Next 801 | SetAttr destinationPath, vbNormal 'Too costly to do after Copy fails 802 | Err.Clear 'Ignore any errors raised by 'SetAttr' 803 | FileCopy sourcePath, destinationPath 'Copies opened files as well 804 | CopyFile = (Err.Number = 0) 805 | On Error GoTo 0 806 | #Else 807 | If Not failIfExists Then 808 | On Error Resume Next 809 | SetAttr destinationPath, vbNormal 'Costly to do after Copy fails 810 | On Error GoTo 0 811 | End If 812 | CopyFile = CopyFileW(StrPtr(sourcePath), StrPtr(destinationPath), failIfExists) 813 | #End If 814 | End Function 815 | 816 | '******************************************************************************* 817 | 'Copies a folder. Ability to copy all subfolders 818 | 'If 'failIfExists' is set to True then this method will fail if any file or 819 | ' subFolder already exists (including the main 'destinationPath') 820 | 'If 'ignoreFailedChildren' is set to True then the method continues to copy the 821 | ' remaining files and subfolders. This is useful when reverting a 'MoveFolder' 822 | ' call across different disk drives. Use this parameter with care 823 | '******************************************************************************* 824 | Public Function CopyFolder(ByRef sourcePath As String _ 825 | , ByRef destinationPath As String _ 826 | , Optional ByVal includeSubFolders As Boolean = True _ 827 | , Optional ByVal failIfExists As Boolean = False _ 828 | , Optional ByVal ignoreFailedChildren As Boolean = False) As Boolean 829 | If Not IsFolder(sourcePath) Then Exit Function 830 | If Not CreateFolder(destinationPath, failIfExists) Then Exit Function 831 | ' 832 | Dim fixedSrc As String: fixedSrc = BuildPath(sourcePath, vbNullString) 833 | Dim fixedDst As String: fixedDst = BuildPath(destinationPath, vbNullString) 834 | ' 835 | If includeSubFolders Then 836 | Dim subFolderPath As Variant 837 | Dim newFolderPath As String 838 | ' 839 | For Each subFolderPath In GetFolders(fixedSrc, True, True, True) 840 | newFolderPath = Replace(subFolderPath, fixedSrc, fixedDst) 841 | If Not CreateFolder(newFolderPath, failIfExists) Then 842 | If Not ignoreFailedChildren Then Exit Function 843 | End If 844 | Next subFolderPath 845 | End If 846 | ' 847 | Dim filePath As Variant 848 | Dim newFilePath As String 849 | ' 850 | For Each filePath In GetFiles(fixedSrc, includeSubFolders, True, True) 851 | newFilePath = Replace(filePath, fixedSrc, fixedDst) 852 | If Not CopyFile(CStr(filePath), newFilePath, failIfExists) Then 853 | If Not ignoreFailedChildren Then Exit Function 854 | End If 855 | Next filePath 856 | ' 857 | CopyFolder = True 858 | End Function 859 | 860 | '******************************************************************************* 861 | 'Creates a folder including parent folders if needed 862 | '******************************************************************************* 863 | Public Function CreateFolder(ByRef folderPath As String _ 864 | , Optional ByVal failIfExists As Boolean = False) As Boolean 865 | If IsFolder(folderPath) Then 866 | CreateFolder = Not failIfExists 867 | Exit Function 868 | End If 869 | ' 870 | Dim fullPath As String 871 | ' 872 | fullPath = BuildPath(folderPath, vbNullString) 873 | fullPath = Left$(fullPath, Len(fullPath) - 1) 'Removing trailing separator 874 | ' 875 | Dim sepIndex As Long 876 | Dim collFoldersToCreate As New Collection 877 | Dim v As Variant 878 | ' 879 | 'Note that the same outcome could be achieved via recursivity but this 880 | ' approach avoids adding extra stack frames to the call stack 881 | collFoldersToCreate.Add fullPath 882 | Do 883 | sepIndex = InStrRev(fullPath, PATH_SEPARATOR) 884 | If sepIndex < 3 Then Exit Do 885 | ' 886 | fullPath = Left$(fullPath, sepIndex - 1) 887 | If IsFolder(fullPath) Then Exit Do 888 | collFoldersToCreate.Add fullPath, Before:=1 889 | Loop 890 | On Error Resume Next 891 | For Each v In collFoldersToCreate 892 | 'MkDir does not support all Unicode characters, unlike FSO 893 | #If Mac Then 894 | MkDir v 895 | #Else 896 | GetFSO.CreateFolder v 897 | #End If 898 | If Err.Number <> 0 Then Exit For 899 | Next v 900 | CreateFolder = (Err.Number = 0) 901 | On Error GoTo 0 902 | End Function 903 | 904 | '******************************************************************************* 905 | 'Deletes a file only. Does not support wildcards * ? 906 | '******************************************************************************* 907 | Public Function DeleteFile(ByRef filePath As String) As Boolean 908 | If LenB(filePath) = 0 Then Exit Function 909 | If Not IsFile(filePath) Then Exit Function 'Avoid 'Kill' on folder 910 | ' 911 | On Error Resume Next 912 | #If Windows Then 913 | GetFSO.DeleteFile filePath, True 914 | DeleteFile = (Err.Number = 0) 915 | If DeleteFile Then Exit Function 916 | Err.Clear 917 | #End If 918 | SetAttr filePath, vbNormal 'Too costly to do after failing Kill 919 | Err.Clear 920 | Kill filePath 921 | DeleteFile = (Err.Number = 0) 922 | On Error GoTo 0 923 | ' 924 | #If Windows Then 925 | If Not DeleteFile Then DeleteFile = CBool(DeleteFileW(StrPtr(filePath))) 926 | #End If 927 | End Function 928 | 929 | '******************************************************************************* 930 | 'Deletes a folder 931 | 'If the 'deleteContents' parameter is set to True then all files/folders inside 932 | ' all subfolders will be deleted before attempting to delete the main folder. 933 | ' In this case no attempt is made to roll back any deleted files/folders in 934 | ' case the method fails (ex. after deleting some files/folders the method 935 | ' cannot delete a particular file that is locked/open and so the method stops 936 | ' and returns False without rolling back the already deleted files/folders) 937 | '******************************************************************************* 938 | Public Function DeleteFolder(ByRef folderPath As String _ 939 | , Optional ByVal deleteContents As Boolean = False _ 940 | , Optional ByVal failIfMissing As Boolean = False) As Boolean 941 | If LenB(folderPath) = 0 Then Exit Function 942 | ' 943 | If Not IsFolder(folderPath) Then 944 | DeleteFolder = Not failIfMissing 945 | Exit Function 946 | End If 947 | ' 948 | On Error Resume Next 949 | RmDir folderPath 'Assume the folder is empty 950 | DeleteFolder = (Err.Number = 0) 951 | If DeleteFolder Then Exit Function 952 | ' 953 | #If Windows Then 954 | Err.Clear 955 | GetFSO.DeleteFolder folderPath, True 956 | DeleteFolder = (Err.Number = 0) 957 | If DeleteFolder Then Exit Function 958 | #End If 959 | On Error GoTo 0 960 | If Not deleteContents Then Exit Function 961 | ' 962 | Dim collFolders As Collection 963 | Dim i As Long 964 | ' 965 | Set collFolders = GetFolders(folderPath, True, True, True) 966 | For i = collFolders.Count To 1 Step -1 'From bottom to top level 967 | If Not DeleteBottomMostFolder(collFolders.Item(i)) Then Exit Function 968 | Next i 969 | ' 970 | DeleteFolder = DeleteBottomMostFolder(folderPath) 971 | End Function 972 | 973 | '******************************************************************************* 974 | 'Utility for 'DeleteFolder' 975 | 'Deletes a folder that can contain files but does NOT contain any other folders 976 | '******************************************************************************* 977 | Private Function DeleteBottomMostFolder(ByRef folderPath As String) As Boolean 978 | Dim fixedPath As String: fixedPath = BuildPath(folderPath, vbNullString) 979 | Dim filePath As Variant 980 | ' 981 | On Error Resume Next 982 | Kill fixedPath 'Try to batch delete all files (if any) 983 | Err.Clear 'Kill fails if there are no files so ignore any error 984 | RmDir fixedPath 'Try to delete folder 985 | If Err.Number = 0 Then 986 | DeleteBottomMostFolder = True 987 | Exit Function 988 | End If 989 | On Error GoTo 0 990 | ' 991 | For Each filePath In GetFiles(fixedPath, False, True, True) 992 | If Not DeleteFile(CStr(filePath)) Then Exit Function 993 | Next filePath 994 | ' 995 | On Error Resume Next 996 | RmDir fixedPath 997 | DeleteBottomMostFolder = (Err.Number = 0) 998 | On Error GoTo 0 999 | ' 1000 | #If Windows Then 1001 | If Not DeleteBottomMostFolder Then 1002 | DeleteBottomMostFolder = CBool(RemoveDirectoryW(StrPtr(fixedPath))) 1003 | End If 1004 | #End If 1005 | End Function 1006 | 1007 | '******************************************************************************* 1008 | 'Fixes a file or folder name, NOT a path 1009 | 'Before creating a file/folder it's useful to fix the name so that the creation 1010 | ' does not fail because of forbidden characters, reserved names or other rules 1011 | '******************************************************************************* 1012 | #If Mac Then 1013 | Public Function FixFileName(ByRef nameToFix As String) As String 1014 | Dim resultName As String 1015 | Dim i As Long: i = 1 1016 | ' 1017 | resultName = Replace(nameToFix, ":", vbNullString) 1018 | resultName = Replace(resultName, "/", vbNullString) 1019 | ' 1020 | 'Names cannot start with a space character 1021 | Do While Mid$(resultName, i, 1) = "." 1022 | i = i + 1 1023 | Loop 1024 | If i > 1 Then resultName = Mid$(resultName, i) 1025 | ' 1026 | FixFileName = resultName 1027 | End Function 1028 | #Else 1029 | Public Function FixFileName(ByRef nameToFix As String _ 1030 | , Optional ByVal isFATFileSystem As Boolean = False) As String 1031 | Dim resultName As String: resultName = nameToFix 1032 | Dim v As Variant 1033 | ' 1034 | For Each v In ForbiddenNameChars(addCaret:=isFATFileSystem) 1035 | resultName = Replace(resultName, v, vbNullString) 1036 | Next v 1037 | ' 1038 | 'Names cannot end in a space or a period character 1039 | Const dotSpace As String = ". " 1040 | Dim nameLen As Long: nameLen = Len(resultName) 1041 | Dim i As Long: i = nameLen 1042 | ' 1043 | If i = 0 Then Exit Function 1044 | Do While InStr(1, dotSpace, Mid$(resultName, i, 1)) > 0 1045 | i = i - 1 1046 | If i = 0 Then Exit Function 1047 | Loop 1048 | If i < nameLen Then resultName = Left$(resultName, i) 1049 | If IsReservedName(resultName) Then Exit Function 1050 | ' 1051 | FixFileName = resultName 1052 | End Function 1053 | #End If 1054 | 1055 | '******************************************************************************* 1056 | 'Returns a collection of forbidden characters for a file/folder name 1057 | 'Ability to add the caret ^ char - forbidden on FAT file systems but not on NTFS 1058 | '******************************************************************************* 1059 | #If Windows Then 1060 | Private Function ForbiddenNameChars(ByVal addCaret As Boolean) As Collection 1061 | Static collForbiddenChars As Collection 1062 | Static hasCaret As Boolean 1063 | ' 1064 | If collForbiddenChars Is Nothing Then 1065 | Set collForbiddenChars = New Collection 1066 | Dim v As Variant 1067 | Dim i As Long 1068 | ' 1069 | For Each v In Split(":,*,?,"",<,>,|,\,/", ",") 1070 | collForbiddenChars.Add v 1071 | Next v 1072 | For i = 0 To 31 'ASCII control characters and the null character 1073 | collForbiddenChars.Add Chr$(i) 1074 | Next i 1075 | End If 1076 | If hasCaret And Not addCaret Then 1077 | collForbiddenChars.Remove 1 1078 | ElseIf Not hasCaret And addCaret Then 1079 | collForbiddenChars.Add Item:="^", Before:=1 1080 | End If 1081 | hasCaret = addCaret 1082 | ' 1083 | Set ForbiddenNameChars = collForbiddenChars 1084 | End Function 1085 | #End If 1086 | 1087 | '******************************************************************************* 1088 | 'Windows file/folder reserved names: com1 to com9, lpt1 to lpt9, con, nul, prn 1089 | '******************************************************************************* 1090 | #If Windows Then 1091 | Private Function IsReservedName(ByRef nameToCheck As String) As Boolean 1092 | Static collReservedNames As Collection 1093 | Dim v As Variant 1094 | ' 1095 | If collReservedNames Is Nothing Then 1096 | Set collReservedNames = New Collection 1097 | For Each v In Split("com1,com2,com3,com4,com5,com6,com7,com8,com9," _ 1098 | & "lpt1,lpt2,lpt3,lpt4,lpt5,lpt6,lpt7,lpt8,lpt9," _ 1099 | & "con,nul,prn,aux", ",") 1100 | collReservedNames.Add Empty, v 1101 | Next v 1102 | End If 1103 | On Error Resume Next 1104 | collReservedNames.Item nameToCheck 1105 | IsReservedName = (Err.Number = 0) 1106 | On Error GoTo 0 1107 | End Function 1108 | #End If 1109 | 1110 | '******************************************************************************* 1111 | 'Fixes path separators for a path 1112 | 'Windows example: replace \\, \\\, \\\\, \\//, \/\/\, /, // etc. with a single \ 1113 | 'Note that on a Mac, the network paths (smb:// or afp://) need to be mounted and 1114 | ' are only valid via the mounted volumes: /volumes/VolumeName/... unlike on a 1115 | ' PC where \\share\data\... is a valid file/folder path (UNC) 1116 | 'Trims any current paths \. as well as any parent folder pairs \{parentName}\.. 1117 | '******************************************************************************* 1118 | Public Function FixPathSeparators(ByRef pathToFix As String) As String 1119 | Const ps As String = PATH_SEPARATOR 1120 | Dim resultPath As String 1121 | Dim isUNC As Boolean 1122 | ' 1123 | If LenB(pathToFix) = 0 Then Exit Function 1124 | #If Mac Then 1125 | resultPath = Replace(pathToFix, "\", ps) 1126 | #Else 1127 | resultPath = Replace(pathToFix, "/", ps) 1128 | If Left$(resultPath, 4) = "\\?\" Then 1129 | If Mid$(resultPath, 5, 4) = "UNC\" Then 1130 | Mid$(resultPath, 7, 1) = "\" 1131 | resultPath = Mid$(resultPath, 7) 1132 | Else 1133 | resultPath = Mid$(resultPath, 5) 1134 | End If 1135 | End If 1136 | isUNC = (Left$(resultPath, 2) = "\\") 1137 | #End If 1138 | ' 1139 | Const fCurrent As String = ps & "." & ps 1140 | Const fParent As String = ps & ".." & ps 1141 | Dim sepIndex As Long 1142 | Dim i As Long: i = 0 1143 | ' 1144 | 'Remove any current folder references 1145 | Do 1146 | i = InStr(i + 1, resultPath, fCurrent) 1147 | If i = 0 Then i = InStr(Len(resultPath) - 1, resultPath, ps & ".") 1148 | If i > 0 Then Mid$(resultPath, i + 1, 1) = ps 1149 | Loop Until i = 0 1150 | ' 1151 | FixPathSeparators = RemoveDuplicatePS(resultPath, isUNC) 1152 | ' 1153 | 'Remove any parent folder references 1154 | i = 1 1155 | Do 1156 | i = InStr(i, FixPathSeparators, fParent) 1157 | If i = 0 And Len(FixPathSeparators) > 2 Then 1158 | i = InStr(Len(FixPathSeparators) - 2, FixPathSeparators, ps & "..") 1159 | End If 1160 | If i > 1 Then 1161 | sepIndex = InStrRev(FixPathSeparators, ps, i - 1) 1162 | If sepIndex < 3 Then sepIndex = i 1163 | FixPathSeparators = Left$(FixPathSeparators, sepIndex) _ 1164 | & Mid$(FixPathSeparators, i + 4) 1165 | If sepIndex < i Then i = i - sepIndex 1166 | End If 1167 | Loop Until i = 0 1168 | End Function 1169 | 1170 | '******************************************************************************* 1171 | 'Utility for 'FixPathSeparators'. Removes any duplicate path separators 1172 | '******************************************************************************* 1173 | Private Function RemoveDuplicatePS(ByRef pathToFix As String _ 1174 | , ByVal isUNC As Boolean) As String 1175 | Const ps As String = PATH_SEPARATOR 1176 | Dim startPos As Long 1177 | Dim currPos As Long 1178 | Dim prevPos As Long 1179 | Dim diff As Long 1180 | Dim i As Long 1181 | ' 1182 | If isUNC Then currPos = 2 'Skip the leading UNC prefix: \\ 1183 | RemoveDuplicatePS = pathToFix 1184 | Do 1185 | prevPos = currPos 1186 | currPos = InStr(currPos + 1, pathToFix, ps) 1187 | If startPos = 0 Then startPos = prevPos + 1 1188 | If currPos - prevPos <= 1 Then 1189 | diff = currPos - startPos 1190 | If currPos = 0 Then diff = diff + Len(pathToFix) + 1 1191 | If startPos * Sgn(i * diff) > 1 Then 1192 | Mid$(RemoveDuplicatePS, i) = Mid$(pathToFix, startPos, diff) 1193 | i = i + diff 1194 | End If 1195 | If i = 0 Then i = (startPos + diff) * Sgn(prevPos) 1196 | startPos = 0 1197 | End If 1198 | Loop Until currPos = 0 1199 | If i > 1 Then RemoveDuplicatePS = Left$(RemoveDuplicatePS, i - 1) 1200 | End Function 1201 | 1202 | '******************************************************************************* 1203 | 'Retrieves the owner name for a file path 1204 | '******************************************************************************* 1205 | #If Windows Then 1206 | Public Function GetFileOwner(ByRef filePath As String) As String 1207 | Const osi As Long = 1 'OWNER_SECURITY_INFORMATION 1208 | Dim sdSize As Long 1209 | ' 1210 | 'Get SECURITY_DESCRIPTOR required Buffer Size 1211 | GetFileSecurity filePath, osi, 0, 0&, sdSize 1212 | If sdSize = 0 Then Exit Function 1213 | ' 1214 | 'Size the SECURITY_DESCRIPTOR buffer 1215 | Dim sd() As Byte: ReDim sd(0 To sdSize - 1) 1216 | ' 1217 | 'Get SECURITY_DESCRIPTOR buffer 1218 | If GetFileSecurity(filePath, osi, sd(0), sdSize, sdSize) = 0 Then 1219 | Exit Function 1220 | End If 1221 | ' 1222 | 'Get owner SSID 1223 | Dim pOwner As LongPtr 1224 | If GetSecurityDescriptorOwner(sd(0), pOwner, 0&) = 0 Then Exit Function 1225 | ' 1226 | 'Get name and domain length 1227 | Dim nameLen As Long, domainLen As Long 1228 | LookupAccountSid vbNullString, pOwner, vbNullString _ 1229 | , nameLen, vbNullString, domainLen, 0& 1230 | If nameLen = 0 Then Exit Function 1231 | ' 1232 | 'Get name and domain 1233 | Dim owName As String: owName = Space$(nameLen - 1) '-1 less Null Char 1234 | Dim owDomain As String: owDomain = Space$(domainLen - 1) 1235 | If LookupAccountSid(vbNullString, pOwner, owName _ 1236 | , nameLen, owDomain, domainLen, 0&) = 0 Then Exit Function 1237 | ' 1238 | 'Return result 1239 | GetFileOwner = owDomain & PATH_SEPARATOR & owName 1240 | End Function 1241 | #End If 1242 | 1243 | '******************************************************************************* 1244 | 'Returns a Collection of all the files (paths) in a specified folder 1245 | 'Warning! On Mac the 'Dir' method only accepts the vbHidden and the vbDirectory 1246 | ' attributes. However the vbHidden attribute does not work - no hidden files 1247 | ' or folders are retrieved regardless if vbHidden is used or not 1248 | 'On Windows, the vbHidden, and vbSystem attributes work fine with 'Dir' but 1249 | ' the vbReadOnly attribute seems to be completely ignored 1250 | '******************************************************************************* 1251 | Public Function GetFiles(ByRef folderPath As String _ 1252 | , Optional ByVal includeSubFolders As Boolean = False _ 1253 | , Optional ByVal includeHidden As Boolean = False _ 1254 | , Optional ByVal includeSystem As Boolean = False) As Collection 1255 | Dim collFiles As New Collection 1256 | Dim fAttribute As VbFileAttribute 1257 | ' 1258 | #If Mac Then 1259 | fAttribute = vbNormal 1260 | 'Both vbReadOnly and vbSystem are raising errors when used in 'Dir' 1261 | 'vbHidden does not raise an error but seems to be ignored entirely 1262 | #Else 1263 | fAttribute = vbReadOnly 'Seems to be ignored entirely anyway 1264 | If includeSystem Then fAttribute = fAttribute + vbSystem 1265 | #End If 1266 | If includeHidden Then fAttribute = fAttribute + vbHidden 1267 | ' 1268 | AddFilesTo collFiles, folderPath, fAttribute 1269 | If includeSubFolders Then 1270 | Dim subFolderPath As Variant 1271 | For Each subFolderPath In GetFolders(folderPath, True, True, True) 1272 | AddFilesTo collFiles, CStr(subFolderPath), fAttribute 1273 | Next subFolderPath 1274 | End If 1275 | ' 1276 | Set GetFiles = collFiles 1277 | End Function 1278 | 1279 | '******************************************************************************* 1280 | 'Utility for 'GetFiles' method 1281 | 'Warning! On Mac the 'Dir' method only accepts the vbHidden and the vbDirectory 1282 | ' attributes. However the vbHidden attribute does not work - no hidden files 1283 | ' or folders are retrieved regardless if vbHidden is used or not 1284 | '******************************************************************************* 1285 | Private Sub AddFilesTo(ByVal collTarget As Collection _ 1286 | , ByRef folderPath As String _ 1287 | , ByVal fAttribute As VbFileAttribute) 1288 | #If Mac Then 1289 | Const maxDirLen As Long = 247 'To be updated 1290 | #Else 1291 | Const maxDirLen As Long = 247 1292 | #End If 1293 | Const errBadFileNameOrNumber As Long = 52 1294 | Dim fileName As String 1295 | Dim fullPath As String 1296 | Dim collTemp As New Collection 1297 | Dim dirFailed As Boolean 1298 | Dim v As Variant 1299 | Dim fixedPath As String: fixedPath = BuildPath(folderPath, vbNullString) 1300 | ' 1301 | On Error Resume Next 1302 | fileName = Dir(fixedPath, fAttribute) 1303 | dirFailed = (Err.Number = errBadFileNameOrNumber) 'Unsupported Unicode 1304 | On Error GoTo 0 1305 | ' 1306 | Do While LenB(fileName) > 0 1307 | collTemp.Add fileName 1308 | If InStr(1, fileName, "?") > 0 Then 'Unsupported Unicode 1309 | Set collTemp = New Collection 1310 | dirFailed = True 1311 | Exit Do 1312 | End If 1313 | fileName = Dir 1314 | Loop 1315 | If dirFailed Or Len(fixedPath) > maxDirLen Then 1316 | #If Mac Then 1317 | 1318 | #Else 1319 | Dim fsoFile As Object 1320 | Dim fsoFolder As Object: Set fsoFolder = GetFSOFolder(fixedPath) 1321 | ' 1322 | If Not fsoFolder Is Nothing Then 1323 | With fsoFolder 1324 | For Each fsoFile In .Files 1325 | collTemp.Add fsoFile.Name 1326 | Next fsoFile 1327 | End With 1328 | End If 1329 | #End If 1330 | End If 1331 | For Each v In collTemp 1332 | collTarget.Add fixedPath & v 1333 | Next v 1334 | End Sub 1335 | 1336 | '******************************************************************************* 1337 | 'For long paths FSO fails in either retrieving the folder or it retrieves the 1338 | ' folder but the SubFolders or Files collections are not correctly populated 1339 | '******************************************************************************* 1340 | #If Windows Then 1341 | Private Function GetFSOFolder(ByRef folderPath As String) As Object 1342 | If Not IsFolder(folderPath) Then Exit Function 1343 | ' 1344 | Dim fso As Object: Set fso = GetFSO() 1345 | Dim fsoFolder As Object 1346 | Dim tempFolder As Object 1347 | ' 1348 | On Error Resume Next 1349 | Set fsoFolder = fso.GetFolder(folderPath) 1350 | If Err.Number <> 0 Then 1351 | Const ps As String = PATH_SEPARATOR 1352 | Dim collNames As New Collection 1353 | Dim i As Long 1354 | Dim parentPath As String: parentPath = folderPath 1355 | Dim folderName As String 1356 | ' 1357 | If Right$(parentPath, 1) = ps Then 1358 | parentPath = Left$(parentPath, Len(parentPath) - 1) 1359 | End If 1360 | Do 1361 | i = InStrRev(parentPath, ps) 1362 | folderName = Mid$(parentPath, i + 1) 1363 | parentPath = Left$(parentPath, i - 1) 1364 | ' 1365 | If collNames.Count = 0 Then 1366 | collNames.Add folderName 1367 | Else 1368 | collNames.Add folderName, Before:=1 1369 | End If 1370 | Err.Clear 1371 | Set fsoFolder = fso.GetFolder(parentPath) 1372 | Loop Until Err.Number = 0 1373 | Do 1374 | Set fsoFolder = fso.GetFolder(fsoFolder.ShortPath) 'Fix .SubFolders 1375 | Set fsoFolder = fsoFolder.SubFolders(collNames(1)) 1376 | collNames.Remove 1 1377 | Loop Until collNames.Count = 0 1378 | End If 1379 | On Error GoTo 0 1380 | Set GetFSOFolder = fso.GetFolder(fsoFolder.ShortPath) 'Fix .Files Bug 1381 | End Function 1382 | #End If 1383 | 1384 | '******************************************************************************* 1385 | 'Returns the FOLDERID of a 'known folder' on Windows 1386 | 'Returns a null string if 'kfID' is not a valid enum value 1387 | 'Source: KnownFolders.h (Windows 11 SDK 10.0.22621.0) (sorted alphabetically) 1388 | 'Note: Most of the FOLDERIDs that are available on a specific device seem to 1389 | ' be registered in the windows registry under 1390 | ' HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\FolderDescriptions 1391 | ' However, it seems that sometimes the SHGetKnownFolderPath function can 1392 | ' process a FOLDERID even if not present in said registry location. 1393 | '******************************************************************************* 1394 | #If Windows Then 1395 | Public Function GetKnownFolderCLSID(ByVal kfID As KnownFolderID) As String 1396 | Static cids([_minKfID] To [_maxKfID]) As String 1397 | ' 1398 | If kfID < [_minKfID] Or kfID > [_maxKfID] Then Exit Function 1399 | If LenB(cids([_minKfID])) = 0 Then 1400 | cids(kfID_AccountPictures) = "{008ca0b1-55b4-4c56-b8a8-4de4b299d3be}" 1401 | cids(kfID_AddNewPrograms) = "{de61d971-5ebc-4f02-a3a9-6c82895e5c04}" 1402 | cids(kfID_AdminTools) = "{724EF170-A42D-4FEF-9F26-B60E846FBA4F}" 1403 | cids(kfID_AllAppMods) = "{7ad67899-66af-43ba-9156-6aad42e6c596}" 1404 | cids(kfID_AppCaptures) = "{EDC0FE71-98D8-4F4A-B920-C8DC133CB165}" 1405 | cids(kfID_AppDataDesktop) = "{B2C5E279-7ADD-439F-B28C-C41FE1BBF672}" 1406 | cids(kfID_AppDataDocuments) = "{7BE16610-1F7F-44AC-BFF0-83E15F2FFCA1}" 1407 | cids(kfID_AppDataFavorites) = "{7CFBEFBC-DE1F-45AA-B843-A542AC536CC9}" 1408 | cids(kfID_AppDataProgramData) = "{559D40A3-A036-40FA-AF61-84CB430A4D34}" 1409 | cids(kfID_ApplicationShortcuts) = "{A3918781-E5F2-4890-B3D9-A7E54332328C}" 1410 | cids(kfID_AppsFolder) = "{1e87508d-89c2-42f0-8a7e-645a0f50ca58}" 1411 | cids(kfID_AppUpdates) = "{a305ce99-f527-492b-8b1a-7e76fa98d6e4}" 1412 | cids(kfID_CameraRoll) = "{AB5FB87B-7CE2-4F83-915D-550846C9537B}" 1413 | cids(kfID_CameraRollLibrary) = "{2B20DF75-1EDA-4039-8097-38798227D5B7}" 1414 | cids(kfID_CDBurning) = "{9E52AB10-F80D-49DF-ACB8-4330F5687855}" 1415 | cids(kfID_ChangeRemovePrograms) = "{df7266ac-9274-4867-8d55-3bd661de872d}" 1416 | cids(kfID_CommonAdminTools) = "{D0384E7D-BAC3-4797-8F14-CBA229B392B5}" 1417 | cids(kfID_CommonOEMLinks) = "{C1BAE2D0-10DF-4334-BEDD-7AA20B227A9D}" 1418 | cids(kfID_CommonPrograms) = "{0139D44E-6AFE-49F2-8690-3DAFCAE6FFB8}" 1419 | cids(kfID_CommonStartMenu) = "{A4115719-D62E-491D-AA7C-E74B8BE3B067}" 1420 | cids(kfID_CommonStartMenuPlaces) = "{A440879F-87A0-4F7D-B700-0207B966194A}" 1421 | cids(kfID_CommonStartup) = "{82A5EA35-D9CD-47C5-9629-E15D2F714E6E}" 1422 | cids(kfID_CommonTemplates) = "{B94237E7-57AC-4347-9151-B08C6C32D1F7}" 1423 | cids(kfID_ComputerFolder) = "{0AC0837C-BBF8-452A-850D-79D08E667CA7}" 1424 | cids(kfID_ConflictFolder) = "{4bfefb45-347d-4006-a5be-ac0cb0567192}" 1425 | cids(kfID_ConnectionsFolder) = "{6F0CD92B-2E97-45D1-88FF-B0D186B8DEDD}" 1426 | cids(kfID_Contacts) = "{56784854-C6CB-462b-8169-88E350ACB882}" 1427 | cids(kfID_ControlPanelFolder) = "{82A74AEB-AEB4-465C-A014-D097EE346D63}" 1428 | cids(kfID_Cookies) = "{2B0F765D-C0E9-4171-908E-08A611B84FF6}" 1429 | cids(kfID_CurrentAppMods) = "{3db40b20-2a30-4dbe-917e-771dd21dd099}" 1430 | cids(kfID_Desktop) = "{B4BFCC3A-DB2C-424C-B029-7FE99A87C641}" 1431 | cids(kfID_DevelopmentFiles) = "{DBE8E08E-3053-4BBC-B183-2A7B2B191E59}" 1432 | cids(kfID_Device) = "{1C2AC1DC-4358-4B6C-9733-AF21156576F0}" 1433 | cids(kfID_DeviceMetadataStore) = "{5CE4A5E9-E4EB-479D-B89F-130C02886155}" 1434 | cids(kfID_Documents) = "{FDD39AD0-238F-46AF-ADB4-6C85480369C7}" 1435 | cids(kfID_DocumentsLibrary) = "{7b0db17d-9cd2-4a93-9733-46cc89022e7c}" 1436 | cids(kfID_Downloads) = "{374DE290-123F-4565-9164-39C4925E467B}" 1437 | cids(kfID_Favorites) = "{1777F761-68AD-4D8A-87BD-30B759FA33DD}" 1438 | cids(kfID_Fonts) = "{FD228CB7-AE11-4AE3-864C-16F3910AB8FE}" 1439 | cids(kfID_Games) = "{CAC52C1A-B53D-4edc-92D7-6B2E8AC19434}" 1440 | cids(kfID_GameTasks) = "{054FAE61-4DD8-4787-80B6-090220C4B700}" 1441 | cids(kfID_History) = "{D9DC8A3B-B784-432E-A781-5A1130A75963}" 1442 | cids(kfID_HomeGroup) = "{52528A6B-B9E3-4add-B60D-588C2DBA842D}" 1443 | cids(kfID_HomeGroupCurrentUser) = "{9B74B6A3-0DFD-4f11-9E78-5F7800F2E772}" 1444 | cids(kfID_ImplicitAppShortcuts) = "{bcb5256f-79f6-4cee-b725-dc34e402fd46}" 1445 | cids(kfID_InternetCache) = "{352481E8-33BE-4251-BA85-6007CAEDCF9D}" 1446 | cids(kfID_InternetFolder) = "{4D9F7874-4E0C-4904-967B-40B0D20C3E4B}" 1447 | cids(kfID_Libraries) = "{1B3EA5DC-B587-4786-B4EF-BD1DC332AEAE}" 1448 | cids(kfID_Links) = "{bfb9d5e0-c6a9-404c-b2b2-ae6db6af4968}" 1449 | cids(kfID_LocalAppData) = "{F1B32785-6FBA-4FCF-9D55-7B8E7F157091}" 1450 | cids(kfID_LocalAppDataLow) = "{A520A1A4-1780-4FF6-BD18-167343C5AF16}" 1451 | cids(kfID_LocalDocuments) = "{f42ee2d3-909f-4907-8871-4c22fc0bf756}" 1452 | cids(kfID_LocalDownloads) = "{7d83ee9b-2244-4e70-b1f5-5393042af1e4}" 1453 | cids(kfID_LocalizedResourcesDir) = "{2A00375E-224C-49DE-B8D1-440DF7EF3DDC}" 1454 | cids(kfID_LocalMusic) = "{a0c69a99-21c8-4671-8703-7934162fcf1d}" 1455 | cids(kfID_LocalPictures) = "{0ddd015d-b06c-45d5-8c4c-f59713854639}" 1456 | cids(kfID_LocalStorage) = "{B3EB08D3-A1F3-496B-865A-42B536CDA0EC}" 1457 | cids(kfID_LocalVideos) = "{35286a68-3c57-41a1-bbb1-0eae73d76c95}" 1458 | cids(kfID_Music) = "{4BD8D571-6D19-48D3-BE97-422220080E43}" 1459 | cids(kfID_MusicLibrary) = "{2112AB0A-C86A-4ffe-A368-0DE96E47012E}" 1460 | cids(kfID_NetHood) = "{C5ABBF53-E17F-4121-8900-86626FC2C973}" 1461 | cids(kfID_NetworkFolder) = "{D20BEEC4-5CA8-4905-AE3B-BF251EA09B53}" 1462 | cids(kfID_Objects3D) = "{31C0DD25-9439-4F12-BF41-7FF4EDA38722}" 1463 | cids(kfID_OneDrive) = "{A52BBA46-E9E1-435f-B3D9-28DAA648C0F6}" 1464 | cids(kfID_OriginalImages) = "{2C36C0AA-5812-4b87-BFD0-4CD0DFB19B39}" 1465 | cids(kfID_PhotoAlbums) = "{69D2CF90-FC33-4FB7-9A0C-EBB0F0FCB43C}" 1466 | cids(kfID_Pictures) = "{33E28130-4E1E-4676-835A-98395C3BC3BB}" 1467 | cids(kfID_PicturesLibrary) = "{A990AE9F-A03B-4e80-94BC-9912D7504104}" 1468 | cids(kfID_Playlists) = "{DE92C1C7-837F-4F69-A3BB-86E631204A23}" 1469 | cids(kfID_PrintersFolder) = "{76FC4E2D-D6AD-4519-A663-37BD56068185}" 1470 | cids(kfID_PrintHood) = "{9274BD8D-CFD1-41C3-B35E-B13F55A758F4}" 1471 | cids(kfID_Profile) = "{5E6C858F-0E22-4760-9AFE-EA3317B67173}" 1472 | cids(kfID_ProgramData) = "{62AB5D82-FDC1-4DC3-A9DD-070D1D495D97}" 1473 | cids(kfID_ProgramFiles) = "{905e63b6-c1bf-494e-b29c-65b732d3d21a}" 1474 | cids(kfID_ProgramFilesCommon) = "{F7F1ED05-9F6D-47A2-AAAE-29D317C6F066}" 1475 | cids(kfID_ProgramFilesCommonX64) = "{6365D5A7-0F0D-45e5-87F6-0DA56B6A4F7D}" 1476 | cids(kfID_ProgramFilesCommonX86) = "{DE974D24-D9C6-4D3E-BF91-F4455120B917}" 1477 | cids(kfID_ProgramFilesX64) = "{6D809377-6AF0-444b-8957-A3773F02200E}" 1478 | cids(kfID_ProgramFilesX86) = "{7C5A40EF-A0FB-4BFC-874A-C0F2E0B9FA8E}" 1479 | cids(kfID_Programs) = "{A77F5D77-2E2B-44C3-A6A2-ABA601054A51}" 1480 | cids(kfID_Public) = "{DFDF76A2-C82A-4D63-906A-5644AC457385}" 1481 | cids(kfID_PublicDesktop) = "{C4AA340D-F20F-4863-AFEF-F87EF2E6BA25}" 1482 | cids(kfID_PublicDocuments) = "{ED4824AF-DCE4-45A8-81E2-FC7965083634}" 1483 | cids(kfID_PublicDownloads) = "{3D644C9B-1FB8-4f30-9B45-F670235F79C0}" 1484 | cids(kfID_PublicGameTasks) = "{DEBF2536-E1A8-4c59-B6A2-414586476AEA}" 1485 | cids(kfID_PublicLibraries) = "{48daf80b-e6cf-4f4e-b800-0e69d84ee384}" 1486 | cids(kfID_PublicMusic) = "{3214FAB5-9757-4298-BB61-92A9DEAA44FF}" 1487 | cids(kfID_PublicPictures) = "{B6EBFB86-6907-413C-9AF7-4FC2ABF07CC5}" 1488 | cids(kfID_PublicRingtones) = "{E555AB60-153B-4D17-9F04-A5FE99FC15EC}" 1489 | cids(kfID_PublicUserTiles) = "{0482af6c-08f1-4c34-8c90-e17ec98b1e17}" 1490 | cids(kfID_PublicVideos) = "{2400183A-6185-49FB-A2D8-4A392A602BA3}" 1491 | cids(kfID_QuickLaunch) = "{52a4f021-7b75-48a9-9f6b-4b87a210bc8f}" 1492 | cids(kfID_Recent) = "{AE50C081-EBD2-438A-8655-8A092E34987A}" 1493 | cids(kfID_RecordedCalls) = "{2f8b40c2-83ed-48ee-b383-a1f157ec6f9a}" 1494 | cids(kfID_RecordedTVLibrary) = "{1A6FDBA2-F42D-4358-A798-B74D745926C5}" 1495 | cids(kfID_RecycleBinFolder) = "{B7534046-3ECB-4C18-BE4E-64CD4CB7D6AC}" 1496 | cids(kfID_ResourceDir) = "{8AD10C31-2ADB-4296-A8F7-E4701232C972}" 1497 | cids(kfID_RetailDemo) = "{12D4C69E-24AD-4923-BE19-31321C43A767}" 1498 | cids(kfID_Ringtones) = "{C870044B-F49E-4126-A9C3-B52A1FF411E8}" 1499 | cids(kfID_RoamedTileImages) = "{AAA8D5A5-F1D6-4259-BAA8-78E7EF60835E}" 1500 | cids(kfID_RoamingAppData) = "{3EB685DB-65F9-4CF6-A03A-E3EF65729F3D}" 1501 | cids(kfID_RoamingTiles) = "{00BCFC5A-ED94-4e48-96A1-3F6217F21990}" 1502 | cids(kfID_SampleMusic) = "{B250C668-F57D-4EE1-A63C-290EE7D1AA1F}" 1503 | cids(kfID_SamplePictures) = "{C4900540-2379-4C75-844B-64E6FAF8716B}" 1504 | cids(kfID_SamplePlaylists) = "{15CA69B3-30EE-49C1-ACE1-6B5EC372AFB5}" 1505 | cids(kfID_SampleVideos) = "{859EAD94-2E85-48AD-A71A-0969CB56A6CD}" 1506 | cids(kfID_SavedGames) = "{4C5C32FF-BB9D-43b0-B5B4-2D72E54EAAA4}" 1507 | cids(kfID_SavedPictures) = "{3B193882-D3AD-4eab-965A-69829D1FB59F}" 1508 | cids(kfID_SavedPicturesLibrary) = "{E25B5812-BE88-4bd9-94B0-29233477B6C3}" 1509 | cids(kfID_SavedSearches) = "{7d1d3a04-debb-4115-95cf-2f29da2920da}" 1510 | cids(kfID_Screenshots) = "{b7bede81-df94-4682-a7d8-57a52620b86f}" 1511 | cids(kfID_SEARCH_CSC) = "{ee32e446-31ca-4aba-814f-a5ebd2fd6d5e}" 1512 | cids(kfID_SEARCH_MAPI) = "{98ec0e18-2098-4d44-8644-66979315a281}" 1513 | cids(kfID_SearchHistory) = "{0D4C3DB6-03A3-462F-A0E6-08924C41B5D4}" 1514 | cids(kfID_SearchHome) = "{190337d1-b8ca-4121-a639-6d472d16972a}" 1515 | cids(kfID_SearchTemplates) = "{7E636BFE-DFA9-4D5E-B456-D7B39851D8A9}" 1516 | cids(kfID_SendTo) = "{8983036C-27C0-404B-8F08-102D10DCFD74}" 1517 | cids(kfID_SidebarDefaultParts) = "{7B396E54-9EC5-4300-BE0A-2482EBAE1A26}" 1518 | cids(kfID_SidebarParts) = "{A75D362E-50FC-4fb7-AC2C-A8BEAA314493}" 1519 | cids(kfID_SkyDrive) = "{A52BBA46-E9E1-435f-B3D9-28DAA648C0F6}" 1520 | cids(kfID_SkyDriveCameraRoll) = "{767E6811-49CB-4273-87C2-20F355E1085B}" 1521 | cids(kfID_SkyDriveDocuments) = "{24D89E24-2F19-4534-9DDE-6A6671FBB8FE}" 1522 | cids(kfID_SkyDriveMusic) = "{C3F2459E-80D6-45DC-BFEF-1F769F2BE730}" 1523 | cids(kfID_SkyDrivePictures) = "{339719B5-8C47-4894-94C2-D8F77ADD44A6}" 1524 | cids(kfID_StartMenu) = "{625B53C3-AB48-4EC1-BA1F-A1EF4146FC19}" 1525 | cids(kfID_StartMenuAllPrograms) = "{F26305EF-6948-40B9-B255-81453D09C785}" 1526 | cids(kfID_Startup) = "{B97D20BB-F46A-4C97-BA10-5E3608430854}" 1527 | cids(kfID_SyncManagerFolder) = "{43668BF8-C14E-49B2-97C9-747784D784B7}" 1528 | cids(kfID_SyncResultsFolder) = "{289a9a43-be44-4057-a41b-587a76d7e7f9}" 1529 | cids(kfID_SyncSetupFolder) = "{0F214138-B1D3-4a90-BBA9-27CBC0C5389A}" 1530 | cids(kfID_System) = "{1AC14E77-02E7-4E5D-B744-2EB1AE5198B7}" 1531 | cids(kfID_SystemX86) = "{D65231B0-B2F1-4857-A4CE-A8E7C6EA7D27}" 1532 | cids(kfID_Templates) = "{A63293E8-664E-48DB-A079-DF759E0509F7}" 1533 | cids(kfID_UserPinned) = "{9e3995ab-1f9c-4f13-b827-48b24b6c7174}" 1534 | cids(kfID_UserProfiles) = "{0762D272-C50A-4BB0-A382-697DCD729B80}" 1535 | cids(kfID_UserProgramFiles) = "{5cd7aee2-2219-4a67-b85d-6c9ce15660cb}" 1536 | cids(kfID_UserProgramFilesCommon) = "{bcbd3057-ca5c-4622-b42d-bc56db0ae516}" 1537 | cids(kfID_UsersFiles) = "{f3ce0f7c-4901-4acc-8648-d5d44b04ef8f}" 1538 | cids(kfID_UsersLibraries) = "{A302545D-DEFF-464b-ABE8-61C8648D939B}" 1539 | cids(kfID_Videos) = "{18989B1D-99B5-455B-841C-AB7C74E4DDFC}" 1540 | cids(kfID_VideosLibrary) = "{491E922F-5643-4af4-A7EB-4E7A138D8174}" 1541 | cids(kfID_Windows) = "{F38BF404-1D43-42F2-9305-67DE0B28FC23}" 1542 | End If 1543 | GetKnownFolderCLSID = cids(kfID) 1544 | End Function 1545 | #End If 1546 | 1547 | '******************************************************************************* 1548 | 'Returns the path of a 'known folder' on Windows 1549 | 'If 'createIfMissing' is set to True, the windows API function will be called 1550 | ' with flags 'KF_FLAG_CREATE' and 'KF_FLAG_INIT' and will create the folder 1551 | ' if it does not currently exist on the system. 1552 | 'The function can raise the following errors: 1553 | ' - 5: (Invalid procedure call) if 'kfID' is not valid 1554 | ' - 76: (Path not found) if 'createIfMissing' = False AND path not found 1555 | ' - 75: (Path/File access error) if path not found because either: 1556 | ' * the specified folder ID is for a known virtual folder 1557 | ' * there are insufficient permissions to create the folder 1558 | ' - 336: (Component not correctly registered) if the path, or the known 1559 | ' folder ID itself are not registered in the windows registry 1560 | ' - 51: (Internal error) if an unexpected error occurs 1561 | '******************************************************************************* 1562 | #If Windows Then 1563 | Public Function GetKnownFolderPath(ByVal kfID As KnownFolderID _ 1564 | , Optional ByVal createIfMissing As Boolean = False) As String 1565 | Const methodName As String = "GetKnownFolderPath" 1566 | Const NOERROR As Long = 0 1567 | Static guids([_minKfID] To [_maxKfID]) As GUID 1568 | ' 1569 | If kfID < [_minKfID] Or kfID > [_maxKfID] Then 1570 | Err.Raise vbErrInvalidProcedureCall, methodName, "Invalid Folder ID" 1571 | ElseIf guids(kfID).data1 = 0 Then 1572 | If CLSIDFromString(StrPtr(GetKnownFolderCLSID(kfID)), guids(kfID)) <> NOERROR Then 1573 | Err.Raise vbErrInvalidProcedureCall, methodName, "Invalid CLSID" 1574 | End If 1575 | End If 1576 | ' 1577 | Const KF_FLAG_CREATE As Long = &H8000& 'Other flags not relevant 1578 | Const KF_FLAG_INIT As Long = &H800& 1579 | Const flagCreateInit As Long = KF_FLAG_CREATE Or KF_FLAG_INIT 1580 | Dim dwFlags As Long: If createIfMissing Then dwFlags = flagCreateInit 1581 | ' 1582 | Const S_OK As Long = 0 1583 | Dim ppszPath As LongPtr 1584 | Dim hRes As Long: hRes = SHGetKnownFolderPath(guids(kfID), dwFlags, 0, ppszPath) 1585 | ' 1586 | If hRes = S_OK Then 1587 | GetKnownFolderPath = Space$(lstrlenW(ppszPath)) 1588 | CopyMemory StrPtr(GetKnownFolderPath), ppszPath, LenB(GetKnownFolderPath) 1589 | End If 1590 | CoTaskMemFree ppszPath 'Memory must be freed, even on fail 1591 | If hRes = S_OK Then Exit Function 1592 | ' 1593 | Const E_FAIL As Long = &H80004005 1594 | Const E_INVALIDARG As Long = &H80070057 1595 | Const HRESULT_ERROR_FILE_NOT_FOUND As Long = &H80070002 1596 | Const HRESULT_ERROR_PATH_NOT_FOUND As Long = &H80070003 1597 | Const HRESULT_ERROR_ACCESS_DENIED As Long = &H80070005 1598 | Const HRESULT_ERROR_NOT_FOUND As Long = &H80070490 1599 | ' 1600 | Select Case hRes 1601 | Case E_FAIL 1602 | Err.Raise vbErrPathFileAccessError, methodName, "Known folder might " _ 1603 | & "be marked 'KF_CATEGORY_VIRTUAL' which does not have a path" 1604 | Case E_INVALIDARG 1605 | Err.Raise vbErrInvalidProcedureCall, methodName _ 1606 | , "Known folder not present on system" 1607 | Case HRESULT_ERROR_FILE_NOT_FOUND 1608 | Err.Raise vbErrPathNotFound, methodName, "KnownFolderID might not exist" 1609 | Case HRESULT_ERROR_PATH_NOT_FOUND, HRESULT_ERROR_NOT_FOUND 1610 | Err.Raise vbErrComponentNotRegistered, methodName, "KnownFolderID " _ 1611 | & "might be registered, but no path registered for it" 1612 | Case HRESULT_ERROR_ACCESS_DENIED 1613 | Err.Raise vbErrPathFileAccessError, methodName, "Access denied" 1614 | Case Else 1615 | Err.Raise vbErrInternalError, methodName, "Unexpected error code" 1616 | End Select 1617 | End Function 1618 | #End If 1619 | 1620 | '******************************************************************************* 1621 | 'Returns a Collection of all the subfolders (paths) in a specified folder 1622 | 'Warning! On Mac the 'Dir' method only accepts the vbHidden and the vbDirectory 1623 | ' attributes. However the vbHidden attribute does not work - no hidden files 1624 | ' or folders are retrieved regardless if vbHidden is used or not 1625 | 'On Windows, the vbHidden, and vbSystem attributes work fine with 'Dir' 1626 | '******************************************************************************* 1627 | Public Function GetFolders(ByRef folderPath As String _ 1628 | , Optional ByVal includeSubFolders As Boolean = False _ 1629 | , Optional ByVal includeHidden As Boolean = False _ 1630 | , Optional ByVal includeSystem As Boolean = False) As Collection 1631 | Dim collFolders As New Collection 1632 | Dim fAttribute As VbFileAttribute 1633 | ' 1634 | fAttribute = vbDirectory 1635 | #If Mac Then 1636 | 'vbSystem is raising an error when used in 'Dir' 1637 | 'vbHidden does not raise an error but seems to be ignored entirely 1638 | #Else 1639 | If includeSystem Then fAttribute = fAttribute + vbSystem 1640 | #End If 1641 | If includeHidden Then fAttribute = fAttribute + vbHidden 1642 | ' 1643 | AddFoldersTo collFolders, folderPath, includeSubFolders, fAttribute 1644 | Set GetFolders = collFolders 1645 | End Function 1646 | 1647 | '******************************************************************************* 1648 | 'Utility for 'GetFolders' method 1649 | 'Returning a Collection and then adding the elements of that collection to 1650 | ' another collection higher up in the stack frame is simply inefficient and 1651 | ' unnecessary when doing recursion. Instead this method adds the elements 1652 | ' directly in the final collection instance ('collTarget'). Top-down approach 1653 | 'Because 'Dir' does not allow recursive calls to 'Dir', a temporary collection 1654 | ' is used to get all the subfolders (only if 'includeSubFolders' is True). 1655 | ' The temporary collection is then iterated in order to get the subfolders for 1656 | ' each of the initial subfolders 1657 | 'Warning! On Mac the 'Dir' method only accepts the vbHidden and the vbDirectory 1658 | ' attributes. However the vbHidden attribute does not work - no hidden files 1659 | ' or folders are retrieved regardless if vbHidden is used or not 1660 | '******************************************************************************* 1661 | Private Sub AddFoldersTo(ByVal collTarget As Collection _ 1662 | , ByRef folderPath As String _ 1663 | , ByVal includeSubFolders As Boolean _ 1664 | , ByVal fAttribute As VbFileAttribute) 1665 | #If Mac Then 1666 | Const maxDirLen As Long = 247 'To be updated 1667 | #Else 1668 | Const maxDirLen As Long = 247 1669 | #End If 1670 | Const errBadFileNameOrNumber As Long = 52 1671 | Const currentDir As String = "." 1672 | Const parentDir As String = ".." 1673 | Dim folderName As String 1674 | Dim fullPath As String 1675 | Dim collFolders As Collection 1676 | Dim collTemp As New Collection 1677 | Dim dirFailed As Boolean 1678 | Dim v As Variant 1679 | Dim fixedPath As String: fixedPath = BuildPath(folderPath, vbNullString) 1680 | ' 1681 | If includeSubFolders Then 1682 | Set collFolders = New Collection 'Temp collection to be iterated later 1683 | Else 1684 | Set collFolders = collTarget 'No recusion so we add directly to target 1685 | End If 1686 | ' 1687 | On Error Resume Next 1688 | folderName = Dir(fixedPath, fAttribute) 1689 | dirFailed = (Err.Number = errBadFileNameOrNumber) 'Unsupported Unicode 1690 | On Error GoTo 0 1691 | ' 1692 | Do While LenB(folderName) > 0 1693 | If folderName <> currentDir And folderName <> parentDir Then 1694 | collTemp.Add folderName 1695 | If InStr(1, folderName, "?") > 0 Then 'Unsupported Unicode 1696 | Set collTemp = New Collection 1697 | dirFailed = True 1698 | Exit Do 1699 | End If 1700 | End If 1701 | folderName = Dir 1702 | Loop 1703 | If dirFailed Or Len(fixedPath) > maxDirLen Then 1704 | #If Mac Then 1705 | 1706 | #Else 1707 | Dim fsoDir As Object 1708 | Dim fsoFolder As Object: Set fsoFolder = GetFSOFolder(fixedPath) 1709 | ' 1710 | If Not fsoFolder Is Nothing Then 1711 | On Error Resume Next 1712 | For Each fsoDir In fsoFolder.SubFolders 1713 | collFolders.Add fixedPath & fsoDir.Name 1714 | Next fsoDir 1715 | On Error GoTo 0 1716 | End If 1717 | #End If 1718 | End If 1719 | For Each v In collTemp 1720 | fullPath = fixedPath & v 1721 | If IsFolder(fullPath) Then collFolders.Add fullPath 1722 | Next v 1723 | If includeSubFolders Then 1724 | Dim subFolderPath As Variant 1725 | ' 1726 | For Each subFolderPath In collFolders 1727 | collTarget.Add subFolderPath 1728 | AddFoldersTo collTarget, CStr(subFolderPath), True, fAttribute 1729 | Next subFolderPath 1730 | End If 1731 | End Sub 1732 | 1733 | '******************************************************************************* 1734 | 'Returns the local drive path for a given path or null string if path not local 1735 | 'Note that the input path does not need to be an existing file/folder 1736 | 'Works with both UNC paths (Win) and OneDrive/SharePoint synchronized paths 1737 | ' 1738 | 'Important! 1739 | 'The expectation is that 'fullPath' is NOT URL encoded. If you have an encoded 1740 | ' path (e.g. in Word, ActiveDocument.Path returns an encoded URL) then use 1741 | ' GetLocalPath(DecodeURL(fullPath)... 1742 | '******************************************************************************* 1743 | Public Function GetLocalPath(ByRef fullPath As String _ 1744 | , Optional ByVal rebuildCache As Boolean = False _ 1745 | , Optional ByVal returnInputOnFail As Boolean = False) As String 1746 | #If Windows Then 1747 | If InStr(1, fullPath, "https://", vbTextCompare) <> 1 Then 1748 | Dim tempPath As String: tempPath = FixPathSeparators(fullPath) 1749 | With GetDriveInfo(tempPath) 1750 | If LenB(.driveLetter) > 0 Then 1751 | GetLocalPath = Replace(tempPath, .driveName _ 1752 | , .driveLetter & ":", 1, 1, vbTextCompare) 1753 | Exit Function 1754 | End If 1755 | End With 1756 | End If 1757 | #End If 1758 | GetLocalPath = GetOneDriveLocalPath(fullPath, rebuildCache) 1759 | If LenB(GetLocalPath) = 0 And returnInputOnFail Then 1760 | GetLocalPath = fullPath 1761 | End If 1762 | End Function 1763 | 1764 | '******************************************************************************* 1765 | 'Returns the UNC path for a given path or null string if path is not remote 1766 | 'Note that the input path does not need to be an existing file/folder 1767 | '******************************************************************************* 1768 | #If Windows Then 1769 | Private Function GetUNCPath(ByRef fullPath As String) As String 1770 | With GetDriveInfo(fullPath) 1771 | If LenB(.shareName) = 0 Then Exit Function 'Not UNC 1772 | GetUNCPath = FixPathSeparators(Replace(fullPath, .driveName, .shareName _ 1773 | , 1, 1, vbTextCompare)) 1774 | End With 1775 | End Function 1776 | #End If 1777 | 1778 | '******************************************************************************* 1779 | 'Returns the relative path for a given 'fullPath' based on another full path 1780 | ' or a Null String if the two paths do not have a common root 1781 | '******************************************************************************* 1782 | Public Function GetRelativePath(ByRef fullPath As String _ 1783 | , ByRef relativeToFullPath As String) As String 1784 | Dim fPath As String 1785 | Dim rPath As String 1786 | ' 1787 | fPath = GetLocalPath(fullPath, , True) 1788 | rPath = GetLocalPath(relativeToFullPath, , True) 1789 | ' 1790 | Const ps As String = PATH_SEPARATOR 1791 | Dim fParent As String 1792 | Dim rParent As String 1793 | Dim prevPos As Long 1794 | Dim currPos As Long 1795 | Dim diff As Long 1796 | Dim isRFile As Boolean 1797 | ' 1798 | Do 1799 | prevPos = currPos 1800 | currPos = InStr(currPos + 1, fPath, ps) 1801 | If currPos <> InStr(prevPos + 1, rPath, ps) Then Exit Do 1802 | diff = currPos - prevPos - 1 1803 | If diff > 0 Then 1804 | fParent = Mid$(fPath, prevPos + 1, diff) 1805 | rParent = Mid$(rPath, prevPos + 1, diff) 1806 | If StrComp(fParent, rParent, vbTextCompare) <> 0 Then Exit Do 1807 | End If 1808 | Loop Until currPos = 0 1809 | If prevPos = 0 Then Exit Function 1810 | ' 1811 | fPath = Mid$(fPath, prevPos + 1) 1812 | isRFile = IsFile(rPath) 1813 | rPath = Mid$(rPath, prevPos + 1) 1814 | ' 1815 | If LenB(rPath) > 0 Then 1816 | Dim psCount As Long 1817 | currPos = 0 1818 | Do 1819 | currPos = InStr(currPos + 1, rPath, ps) 1820 | psCount = psCount + 1 1821 | Loop Until currPos = 0 1822 | If Right$(rPath, 1) = ps Or isRFile Then psCount = psCount - 1 1823 | End If 1824 | If psCount > 0 Then 1825 | GetRelativePath = Replace(Space$(psCount), " ", ".." & ps) & fPath 1826 | Else 1827 | GetRelativePath = "." & ps & fPath 1828 | End If 1829 | End Function 1830 | 1831 | '******************************************************************************* 1832 | 'Returns the web path for a OneDrive local path or null string if not OneDrive 1833 | 'Note that the input path does not need to be an existing file/folder 1834 | '******************************************************************************* 1835 | Public Function GetRemotePath(ByRef fullPath As String _ 1836 | , Optional ByVal rebuildCache As Boolean = False _ 1837 | , Optional ByVal returnInputOnFail As Boolean = False) As String 1838 | Dim tempPath As String: tempPath = FixPathSeparators(fullPath) 1839 | #If Windows Then 1840 | GetRemotePath = GetUNCPath(tempPath) 1841 | If LenB(GetRemotePath) > 0 Then Exit Function 1842 | #End If 1843 | GetRemotePath = GetOneDriveWebPath(tempPath, rebuildCache) 1844 | If LenB(GetRemotePath) = 0 And returnInputOnFail Then 1845 | GetRemotePath = fullPath 1846 | End If 1847 | End Function 1848 | 1849 | '******************************************************************************* 1850 | 'Source: https://developer.apple.com/library/archive/documentation/AppleScript/Conceptual/AppleScriptLangGuide/reference/ASLR_cmds.html 1851 | 'Returns a special folder constant on Mac based on the corresponding enum value 1852 | '******************************************************************************* 1853 | #If Mac Then 1854 | Public Function GetSpecialFolderConstant(ByVal sfc As SpecialFolderConstant) As String 1855 | Static sfcs([_minSFC] To [_maxSFC]) As String 1856 | ' 1857 | If sfc < [_minSFC] Or sfc > [_maxSFC] Then Exit Function 1858 | If LenB(sfcs([_minSFC])) = 0 Then 1859 | sfcs(sfc_ApplicationSupport) = "application support" 1860 | sfcs(sfc_ApplicationsFolder) = "applications folder" 1861 | sfcs(sfc_Desktop) = "desktop" 1862 | sfcs(sfc_DesktopPicturesFolder) = "desktop pictures folder" 1863 | sfcs(sfc_DocumentsFolder) = "documents folder" 1864 | sfcs(sfc_DownloadsFolder) = "downloads folder" 1865 | sfcs(sfc_FavoritesFolder) = "favorites folder" 1866 | sfcs(sfc_FolderActionScripts) = "Folder Action scripts" 1867 | sfcs(sfc_Fonts) = "fonts" 1868 | sfcs(sfc_Help) = "help" 1869 | sfcs(sfc_HomeFolder) = "home folder" 1870 | sfcs(sfc_InternetPlugins) = "internet plugins" 1871 | sfcs(sfc_KeychainFolder) = "keychain folder" 1872 | sfcs(sfc_LibraryFolder) = "library folder" 1873 | sfcs(sfc_ModemScripts) = "modem scripts" 1874 | sfcs(sfc_MoviesFolder) = "movies folder" 1875 | sfcs(sfc_MusicFolder) = "music folder" 1876 | sfcs(sfc_PicturesFolder) = "pictures folder" 1877 | sfcs(sfc_Preferences) = "preferences" 1878 | sfcs(sfc_PrinterDescriptions) = "printer descriptions" 1879 | sfcs(sfc_PublicFolder) = "public folder" 1880 | sfcs(sfc_ScriptingAdditions) = "scripting additions" 1881 | sfcs(sfc_ScriptsFolder) = "scripts folder" 1882 | sfcs(sfc_ServicesFolder) = "services folder" 1883 | sfcs(sfc_SharedDocuments) = "shared documents" 1884 | sfcs(sfc_SharedLibraries) = "shared libraries" 1885 | sfcs(sfc_SitesFolder) = "sites folder" 1886 | sfcs(sfc_StartupDisk) = "startup disk" 1887 | sfcs(sfc_StartupItems) = "startup items" 1888 | sfcs(sfc_SystemFolder) = "system folder" 1889 | sfcs(sfc_SystemPreferences) = "system preferences" 1890 | sfcs(sfc_TemporaryItems) = "temporary items" 1891 | sfcs(sfc_Trash) = "trash" 1892 | sfcs(sfc_UsersFolder) = "users folder" 1893 | sfcs(sfc_UtilitiesFolder) = "utilities folder" 1894 | sfcs(sfc_WorkflowsFolder) = "workflows folder" 1895 | ' 1896 | 'Classic domain only 1897 | sfcs(sfc_AppleMenu) = "apple menu" 1898 | sfcs(sfc_ControlPanels) = "control panels" 1899 | sfcs(sfc_ControlStripModules) = "control strip modules" 1900 | sfcs(sfc_Extensions) = "extensions" 1901 | sfcs(sfc_LauncherItemsFolder) = "launcher items folder" 1902 | sfcs(sfc_PrinterDrivers) = "printer drivers" 1903 | sfcs(sfc_Printmonitor) = "printmonitor" 1904 | sfcs(sfc_ShutdownFolder) = "shutdown folder" 1905 | sfcs(sfc_SpeakableItems) = "speakable items" 1906 | sfcs(sfc_Stationery) = "stationery" 1907 | sfcs(sfc_Voices) = "voices" 1908 | End If 1909 | GetSpecialFolderConstant = sfcs(sfc) 1910 | End Function 1911 | #End If 1912 | 1913 | '******************************************************************************* 1914 | 'Returns a special folder domain on Mac based on the corresponding enum value 1915 | '******************************************************************************* 1916 | #If Mac Then 1917 | Public Function GetSpecialFolderDomain(ByVal sfd As SpecialFolderDomain) As String 1918 | Static sfds([_minSFD] To [_maxSFD]) As String 1919 | ' 1920 | If sfd < [_minSFD] Or sfd > [_maxSFD] Then Exit Function 1921 | If LenB(sfds([_maxSFD])) = 0 Then 1922 | sfds(sfd_System) = "system" 1923 | sfds(sfd_Local) = "local" 1924 | sfds(sfd_Network) = "network" 1925 | sfds(sfd_User) = "user" 1926 | sfds(sfd_Classic) = "classic" 1927 | End If 1928 | GetSpecialFolderDomain = sfds(sfd) 1929 | End Function 1930 | #End If 1931 | 1932 | '******************************************************************************* 1933 | 'Returns the path of a 'special folder' on Mac 1934 | 'If 'createIfMissing' is set to True, the function will try to create the folder 1935 | ' if it does not currently exist on the system. Note that this argument 1936 | ' ignores the 'forceNonSandboxedPath' option, and it can happen that the 1937 | ' folder gets created in the sandboxed location and the function returns a non 1938 | ' sandboxed path. This behavior can not be avoided without creating access 1939 | ' requests, therefore it should be taken into account by the user 1940 | 'The function can raise the following errors: 1941 | ' - 5: (Invalid procedure call) if 'sfc' or 'sfd' is invalid 1942 | ' - 76: (Path not found) if 'createIfMissing' = False AND path not found 1943 | ' - 75: (Path/File access error) if 'createIfMissing'= True AND path not found 1944 | '******************************************************************************* 1945 | #If Mac Then 1946 | Public Function GetSpecialFolderPath(ByVal sfc As SpecialFolderConstant _ 1947 | , Optional ByVal sfd As SpecialFolderDomain = [_sfdNone] _ 1948 | , Optional ByVal forceNonSandboxedPath As Boolean = True _ 1949 | , Optional ByVal createIfMissing As Boolean = False) As String 1950 | Const methodName As String = "GetSpecialFolderPath" 1951 | ' 1952 | If sfc < [_minSFC] Or sfc > [_maxSFC] _ 1953 | Or sfd < [_minSFD] Or sfd > [_maxSFD] Then 1954 | Err.Raise vbErrInvalidProcedureCall, methodName, "Invalid constant/domain" 1955 | End If 1956 | ' 1957 | Dim cmd As String: cmd = GetSpecialFolderConstant(sfc) 1958 | ' 1959 | If sfd <> [_sfdNone] Then cmd = cmd & " from " & GetSpecialFolderDomain(sfd) & " domain" 1960 | cmd = cmd & IIf(createIfMissing, " with", " without") & " folder creation" 1961 | cmd = "return POSIX path of (path to " & cmd & ") as string" 1962 | ' 1963 | On Error Resume Next 1964 | Dim app As Object: Set app = Application 1965 | Dim inExcel As Boolean: inExcel = (app.Name = "Microsoft Excel") 1966 | Dim appVersion As Double: appVersion = Val(app.Version) 1967 | On Error GoTo 0 1968 | ' 1969 | If inExcel And appVersion < 15 Then 'Old excel version 1970 | cmd = Replace(cmd, "POSIX path of ", vbNullString, , 1) 1971 | End If 1972 | ' 1973 | On Error GoTo PathDoesNotExist 1974 | GetSpecialFolderPath = MacScript(cmd) 1975 | On Error GoTo 0 1976 | ' 1977 | If forceNonSandboxedPath Then 1978 | Dim sboxPath As String: sboxPath = Environ$("HOME") 1979 | Dim i As Long: i = InStrRev(sboxPath, "/Library/Containers/") 1980 | Dim sboxRelPath As String: If i > 0 Then sboxRelPath = Mid$(sboxPath, i) 1981 | GetSpecialFolderPath = Replace(GetSpecialFolderPath, sboxRelPath _ 1982 | , vbNullString, , 1, vbTextCompare) 1983 | End If 1984 | If LenB(GetSpecialFolderPath) > 0 Then Exit Function 1985 | PathDoesNotExist: 1986 | Const errMsg As String = "Not available or needs specific domain" 1987 | If createIfMissing Then 1988 | Err.Raise vbErrPathFileAccessError, methodName, errMsg 1989 | Else 1990 | Err.Raise vbErrPathNotFound, methodName, errMsg 1991 | End If 1992 | End Function 1993 | #End If 1994 | 1995 | '******************************************************************************* 1996 | 'Returns basic drive information about a full path 1997 | '******************************************************************************* 1998 | #If Windows Then 1999 | Private Function GetDriveInfo(ByRef fullPath As String) As DRIVE_INFO 2000 | Dim fso As Object: Set fso = GetFSO() 2001 | If fso Is Nothing Then Exit Function 2002 | ' 2003 | Dim driveName As String: driveName = fso.GetDriveName(fullPath) 2004 | If LenB(driveName) = 0 Then Exit Function 2005 | ' 2006 | Dim fsDrive As Object 2007 | On Error Resume Next 2008 | Set fsDrive = fso.GetDrive(driveName) 2009 | On Error GoTo 0 2010 | If fsDrive Is Nothing Then Exit Function 2011 | ' 2012 | If LenB(fsDrive.driveLetter) = 0 Then 2013 | Dim sn As Long: sn = fsDrive.SerialNumber 2014 | Dim tempDrive As Object 2015 | Dim tempSN As Long 2016 | Dim isFound As Boolean 2017 | ' 2018 | On Error Resume Next 'In case Drive is not connected 2019 | For Each tempDrive In fso.Drives 2020 | tempSN = tempDrive.SerialNumber 2021 | If tempSN = sn Then 2022 | Set fsDrive = tempDrive 2023 | isFound = True 2024 | Exit For 2025 | End If 2026 | Next tempDrive 2027 | On Error GoTo 0 2028 | If Not isFound Then Exit Function 2029 | End If 2030 | ' 2031 | With GetDriveInfo 2032 | .driveName = driveName 2033 | .driveLetter = fsDrive.driveLetter 2034 | .fileSystem = fsDrive.fileSystem 2035 | .shareName = fsDrive.shareName 2036 | If LenB(.shareName) > 0 Then 2037 | .driveName = AlignDriveNameIfNeeded(.driveName, .shareName) 2038 | End If 2039 | End With 2040 | End Function 2041 | #End If 2042 | 2043 | '******************************************************************************* 2044 | 'Late-bounded file system for Windows 2045 | '******************************************************************************* 2046 | #If Windows Then 2047 | Private Function GetFSO() As Object 2048 | Static fso As Object 2049 | ' 2050 | If fso Is Nothing Then 2051 | On Error Resume Next 2052 | Set fso = CreateObject("Scripting.FileSystemObject") 2053 | On Error GoTo 0 2054 | End If 2055 | Set GetFSO = fso 2056 | End Function 2057 | #End If 2058 | 2059 | '******************************************************************************* 2060 | 'Aligns a wrong drive name with the share name 2061 | 'Example: \\emea\ to \\emea.companyName.net\ 2062 | '******************************************************************************* 2063 | #If Windows Then 2064 | Private Function AlignDriveNameIfNeeded(ByRef driveName As String _ 2065 | , ByRef shareName As String) As String 2066 | Dim sepIndex As Long 2067 | ' 2068 | sepIndex = InStr(3, driveName, PATH_SEPARATOR) 2069 | If sepIndex > 0 Then 2070 | Dim newName As String: newName = Left$(driveName, sepIndex - 1) 2071 | sepIndex = InStr(3, shareName, PATH_SEPARATOR) 2072 | newName = newName & Right$(shareName, Len(shareName) - sepIndex + 1) 2073 | AlignDriveNameIfNeeded = newName 2074 | Else 2075 | AlignDriveNameIfNeeded = driveName 2076 | End If 2077 | End Function 2078 | #End If 2079 | 2080 | Public Function DecodeURL(ByRef odWebPath As String) As String 2081 | Static nibbleMap(0 To 255) As Long 'Nibble: 0 to F. Byte: 00 to FF 2082 | Static charMap(0 To 255) As String 2083 | Dim i As Long 2084 | ' 2085 | If nibbleMap(0) = 0 Then 2086 | For i = 0 To 255 2087 | nibbleMap(i) = -256 'To force invalid character code 2088 | charMap(i) = ChrW$(i) 2089 | Next i 2090 | For i = 0 To 9 2091 | nibbleMap(Asc(CStr(i))) = i 2092 | Next i 2093 | For i = 10 To 15 2094 | nibbleMap(i + 55) = i 'Asc("A") to Asc("F") 2095 | nibbleMap(i + 87) = i 'Asc("a") to Asc("f") 2096 | Next i 2097 | End If 2098 | ' 2099 | DecodeURL = odWebPath 'Buffer 2100 | ' 2101 | Dim b() As Byte: b = odWebPath 2102 | Dim pathLen As Long: pathLen = Len(odWebPath) 2103 | Dim maxFind As Long: maxFind = pathLen * 2 - 4 2104 | Dim codeW As Integer 2105 | Dim j As Long 2106 | Dim diff As Long 2107 | Dim chunkLen As Long 2108 | ' 2109 | i = InStrB(1, odWebPath, "%") 2110 | Do While i > 0 And i < maxFind 2111 | codeW = nibbleMap(b(i + 1)) * &H10& + nibbleMap(b(i + 3)) 2112 | If codeW > 0 And b(i + 2) = 0 And b(i + 4) = 0 Then 2113 | If j > 0 Then 2114 | chunkLen = i - j 2115 | If chunkLen > 0 Then 2116 | MidB$(DecodeURL, j - diff) = MidB$(odWebPath, j, chunkLen) 2117 | End If 2118 | End If 2119 | MidB$(DecodeURL, i - diff) = charMap(codeW) 2120 | i = i + 4 2121 | j = i + 2 2122 | diff = diff + 4 2123 | End If 2124 | i = InStrB(i + 2, odWebPath, "%") 2125 | Loop 2126 | If diff > 0 Then 2127 | chunkLen = pathLen * 2 + 1 - j 2128 | If chunkLen > 0 Then 2129 | MidB$(DecodeURL, j - diff) = MidB$(odWebPath, j, chunkLen) 2130 | End If 2131 | DecodeURL = Left$(DecodeURL, pathLen - diff / 2) 2132 | End If 2133 | End Function 2134 | 2135 | '******************************************************************************* 2136 | 'Returns the local path for a OneDrive web path 2137 | 'Returns null string if the path provided is not a valid OneDrive web path 2138 | ' 2139 | 'With the help of: @guwidoe (https://github.com/guwidoe) 2140 | 'See: https://github.com/cristianbuse/VBA-FileTools/issues/1 2141 | '******************************************************************************* 2142 | Private Function GetOneDriveLocalPath(ByVal odWebPath As String _ 2143 | , ByVal rebuildCache As Boolean) As String 2144 | If InStr(1, odWebPath, "https://", vbTextCompare) <> 1 Then Exit Function 2145 | ' 2146 | Dim collMatches As New Collection 2147 | Dim bestMatch As Long 2148 | Dim mainIndex As Long 2149 | Dim i As Long 2150 | ' 2151 | ReadODProviders rebuildCache 2152 | For i = 1 To m_providers.pCount 2153 | If StrCompLeft(odWebPath, m_providers.arr(i).webPath, vbTextCompare) = 0 Then 2154 | collMatches.Add i 2155 | If Not m_providers.arr(i).isBusiness Then Exit For 2156 | If m_providers.arr(i).isMain Then 2157 | mainIndex = m_providers.arr(i).accountIndex 2158 | End If 2159 | End If 2160 | Next i 2161 | ' 2162 | Select Case collMatches.Count 2163 | Case 0: Exit Function 2164 | Case 1: bestMatch = collMatches(1) 2165 | Case Else 2166 | Dim pos As Long: pos = Len(odWebPath) + 1 2167 | Dim tempPath As String 2168 | Dim webPath As String 2169 | Dim rPart As String 2170 | Dim localPath As String 2171 | Dim v As Variant 2172 | Do 2173 | pos = InStrRev(odWebPath, "/", pos - 1) 2174 | tempPath = Left$(odWebPath, pos) 2175 | For Each v In collMatches 2176 | With m_providers.arr(v) 2177 | rPart = Mid$(tempPath, Len(.webPath) + 1) 2178 | localPath = BuildPath(.mountPoint, rPart) 2179 | If IsFolder(localPath) Then 2180 | If bestMatch = 0 Or .isMain Then 2181 | bestMatch = v 2182 | Else 2183 | If IsBetterMatch(m_providers.arr(bestMatch) _ 2184 | , m_providers.arr(v) _ 2185 | , mainIndex _ 2186 | , localPath) Then 2187 | bestMatch = v 2188 | End If 2189 | End If 2190 | End If 2191 | End With 2192 | Next v 2193 | Loop Until bestMatch > 0 2194 | End Select 2195 | With m_providers.arr(bestMatch) 2196 | rPart = Mid$(odWebPath, Len(.webPath) + 1) 2197 | GetOneDriveLocalPath = BuildPath(.mountPoint, rPart) 2198 | End With 2199 | End Function 2200 | Private Function StrCompLeft(ByRef s1 As String _ 2201 | , ByRef s2 As String _ 2202 | , ByVal compareMethod As VbCompareMethod) As Long 2203 | If Len(s1) > Len(s2) Then 2204 | StrCompLeft = StrComp(Left$(s1, Len(s2)), s2, compareMethod) 2205 | Else 2206 | StrCompLeft = StrComp(s1, Left$(s2, Len(s1)), compareMethod) 2207 | End If 2208 | End Function 2209 | Private Function IsBetterMatch(ByRef lastProvider As ONEDRIVE_PROVIDER _ 2210 | , ByRef currProvider As ONEDRIVE_PROVIDER _ 2211 | , ByRef mainIndex As Long _ 2212 | , ByRef localPath As String) As Boolean 2213 | If lastProvider.isMain Then Exit Function 2214 | ' 2215 | Dim isLastOnMain As Boolean: isLastOnMain = (lastProvider.accountIndex = mainIndex) 2216 | Dim isCurrOnMain As Boolean: isCurrOnMain = (currProvider.accountIndex = mainIndex) 2217 | ' 2218 | If isLastOnMain Xor isCurrOnMain Then 2219 | IsBetterMatch = isCurrOnMain 2220 | Else 2221 | IsBetterMatch = IsFolderEditable(localPath) 2222 | End If 2223 | End Function 2224 | 2225 | '******************************************************************************* 2226 | 'Returns the web path for a OneDrive local path 2227 | 'Returns null string if the path provided is not a valid OneDrive local path 2228 | '******************************************************************************* 2229 | Private Function GetOneDriveWebPath(ByRef odLocalPath As String _ 2230 | , ByVal rebuildCache As Boolean) As String 2231 | Dim localPath As String 2232 | Dim rPart As String 2233 | Dim bestMatch As Long 2234 | Dim i As Long 2235 | Dim fixedPath As String: fixedPath = FixPathSeparators(odLocalPath) 2236 | ' 2237 | ReadODProviders rebuildCache 2238 | For i = 1 To m_providers.pCount 2239 | localPath = m_providers.arr(i).mountPoint 2240 | If StrCompLeft(fixedPath, localPath, vbTextCompare) = 0 Then 2241 | If bestMatch = 0 Then 2242 | bestMatch = i 2243 | ElseIf Len(localPath) > Len(m_providers.arr(bestMatch).mountPoint) _ 2244 | Then 2245 | bestMatch = i 2246 | End If 2247 | End If 2248 | Next i 2249 | If bestMatch = 0 Then Exit Function 2250 | ' 2251 | With m_providers.arr(bestMatch) 2252 | rPart = Replace(Mid$(fixedPath, Len(.mountPoint) + 1), "\", "/") 2253 | GetOneDriveWebPath = .webPath & rPart 2254 | End With 2255 | End Function 2256 | 2257 | '******************************************************************************* 2258 | 'Populates the OneDrive providers in the 'm_providers' structure 2259 | 'Utility for 'GetOneDriveLocalPath' and 'GetOneDriveWebPath' 2260 | '******************************************************************************* 2261 | Private Sub ReadODProviders(ByVal rebuildCache As Boolean) 2262 | Dim i As Long 2263 | Dim accountsInfo As ONEDRIVE_ACCOUNTS_INFO 2264 | Dim fileName As String 2265 | Static collTrackedFiles As Collection 2266 | Const oneSecond As Date = 1 / 86400 2267 | ' 2268 | If Not rebuildCache And m_providers.isSet Then 2269 | If m_providers.lastCacheUpdate + oneSecond > Now() Then Exit Sub 2270 | Dim v As Variant 2271 | On Error Resume Next 2272 | For Each v In collTrackedFiles 2273 | If FileDateTime(v) > m_providers.lastCacheUpdate _ 2274 | Or Err.Number <> 0 Then 2275 | rebuildCache = True 2276 | Exit For 2277 | End If 2278 | Next v 2279 | On Error GoTo 0 2280 | If Not rebuildCache Then 2281 | m_providers.lastCacheUpdate = Now() 2282 | Exit Sub 2283 | End If 2284 | End If 2285 | ' 2286 | m_providers.pCount = 0 2287 | m_providers.isSet = False 2288 | ' 2289 | ReadODAccountsInfo accountsInfo 2290 | If Not accountsInfo.isSet Then Exit Sub 2291 | ' 2292 | #If Mac Then 'Grant access to all needed files/folders, in batch 2293 | Dim collFiles As New Collection 2294 | ' 2295 | For i = 1 To accountsInfo.pCount 2296 | With accountsInfo.arr(i) 2297 | collFiles.Add .iniPath 2298 | collFiles.Add .datPath 2299 | collFiles.Add .dbPath 2300 | collFiles.Add .clientPath 2301 | collFiles.Add .globalPath 2302 | If .isPersonal Then 2303 | collFiles.Add .groupPath 2304 | Else 2305 | fileName = Dir(Replace(.clientPath, ".ini", "_*.ini")) 2306 | Do While LenB(fileName) > 0 2307 | collFiles.Add .folderPath & "/" & fileName 2308 | fileName = Dir 2309 | Loop 2310 | End If 2311 | End With 2312 | Next i 2313 | ' 2314 | Const syncIDFileName As String = ".849C9593-D756-4E56-8D6E-42412F2A707B" 2315 | Dim collCloudDirs As Collection: Set collCloudDirs = GetODCloudDirs() 2316 | Dim odCloudDir As Variant 2317 | Dim arrPaths() As String 2318 | Dim syncID As String 2319 | Dim folderPath As String 2320 | Dim collSyncIDToDir As New Collection 2321 | ' 2322 | For Each odCloudDir In collCloudDirs 2323 | collFiles.Add odCloudDir 2324 | collFiles.Add odCloudDir & "/" & syncIDFileName 2325 | Next odCloudDir 2326 | arrPaths = CollectionToStrings(collFiles) 2327 | If Not GrantAccessToMultipleFiles(arrPaths) Then Exit Sub 2328 | ' 2329 | Set collFiles = New Collection 2330 | For Each odCloudDir In collCloudDirs 2331 | syncID = ReadSyncID(odCloudDir & "/" & syncIDFileName) 2332 | If LenB(syncID) > 0 Then 2333 | collSyncIDToDir.Add odCloudDir, syncID 2334 | Else 2335 | fileName = Dir(odCloudDir & "/", vbDirectory) 2336 | Do While LenB(fileName) > 0 2337 | folderPath = odCloudDir & "/" & fileName 2338 | collFiles.Add folderPath 2339 | collFiles.Add folderPath & "/" & syncIDFileName 2340 | fileName = Dir 2341 | Loop 2342 | End If 2343 | Next odCloudDir 2344 | If collFiles.Count > 0 Then 2345 | arrPaths = CollectionToStrings(collFiles) 2346 | If Not GrantAccessToMultipleFiles(arrPaths) Then Exit Sub 2347 | ' 2348 | For i = LBound(arrPaths) To UBound(arrPaths) Step 2 2349 | syncID = ReadSyncID(arrPaths(i + 1)) 2350 | If LenB(syncID) > 0 Then collSyncIDToDir.Add arrPaths(i), syncID 2351 | Next i 2352 | End If 2353 | #End If 2354 | For i = 1 To accountsInfo.pCount 'Check for unsynchronized accounts 2355 | Dim j As Long 2356 | For j = i + 1 To accountsInfo.pCount 2357 | ValidateAccounts accountsInfo.arr(i), accountsInfo.arr(j) 2358 | Next j 2359 | Next i 2360 | Set collTrackedFiles = New Collection 2361 | For i = 1 To accountsInfo.pCount 2362 | With accountsInfo.arr(i) 2363 | If .isValid Then 2364 | If .isPersonal Then 2365 | AddPersonalProviders accountsInfo.arr(i) 2366 | collTrackedFiles.Add .groupPath 2367 | Else 2368 | AddBusinessProviders accountsInfo.arr(i) 2369 | fileName = Dir(Replace(.clientPath, ".ini", "_*.ini")) 2370 | Do While LenB(fileName) > 0 2371 | collTrackedFiles.Add .folderPath & "/" & fileName 2372 | fileName = Dir 2373 | Loop 2374 | End If 2375 | If .hasDatFile Then 2376 | collTrackedFiles.Add .datPath 2377 | Else 2378 | collTrackedFiles.Add .dbPath 2379 | End If 2380 | collTrackedFiles.Add .clientPath 2381 | collTrackedFiles.Add .globalPath 2382 | collTrackedFiles.Add .iniPath 2383 | End If 2384 | End With 2385 | Next i 2386 | #If Mac Then 2387 | If collSyncIDToDir.Count > 0 Then 'Replace sandbox paths 2388 | For i = 1 To m_providers.pCount 2389 | With m_providers.arr(i) 2390 | On Error Resume Next 2391 | .syncDir = collSyncIDToDir(.syncID) 2392 | .mountPoint = Replace(.mountPoint, .baseMount, .syncDir) 2393 | On Error GoTo 0 2394 | End With 2395 | Next i 2396 | End If 2397 | #End If 2398 | m_providers.isSet = True 2399 | m_providers.lastCacheUpdate = Now() 2400 | #If Mac Then 2401 | ClearConversionDescriptors 2402 | #End If 2403 | End Sub 2404 | 2405 | '******************************************************************************* 2406 | 'Mac utilities for reading OneDrive providers 2407 | '******************************************************************************* 2408 | #If Mac Then 2409 | Private Function GetODCloudDirs() As Collection 2410 | Dim coll As New Collection 2411 | Dim cloudPath As String: cloudPath = GetCloudPath() 2412 | Dim folderName As String: folderName = Dir(cloudPath, vbDirectory) 2413 | ' 2414 | Do While LenB(folderName) > 0 2415 | If folderName Like "OneDrive*" Then 2416 | coll.Add BuildPath(cloudPath, folderName) 2417 | End If 2418 | folderName = Dir 2419 | Loop 2420 | Set GetODCloudDirs = coll 2421 | End Function 2422 | Private Function GetCloudPath() As String 2423 | GetCloudPath = GetUserPath() & "Library/CloudStorage/" 2424 | End Function 2425 | Private Function GetUserPath() As String 2426 | GetUserPath = "/Users/" & Environ$("USER") & "/" 2427 | End Function 2428 | Private Function CollectionToStrings(ByVal coll As Collection) As String() 2429 | If coll.Count = 0 Then 2430 | CollectionToStrings = Split(vbNullString) 2431 | Exit Function 2432 | End If 2433 | ' 2434 | Dim res() As String: ReDim res(0 To coll.Count - 1) 2435 | Dim i As Long 2436 | Dim v As Variant 2437 | ' 2438 | For Each v In coll 2439 | res(i) = v 2440 | i = i + 1 2441 | Next v 2442 | CollectionToStrings = res 2443 | End Function 2444 | Private Function ReadSyncID(ByRef syncFilePath As String) As String 2445 | Dim b() As Byte: ReadBytes syncFilePath, b 2446 | Dim parts() As String: parts = Split(StrConv(b, vbUnicode), """guid"" : """) 2447 | ' 2448 | If UBound(parts) < 1 Then Exit Function 2449 | ReadSyncID = Left$(parts(1), InStr(1, parts(1), """") - 1) 2450 | End Function 2451 | #End If 2452 | Private Sub ValidateAccounts(ByRef a1 As ONEDRIVE_ACCOUNT_INFO _ 2453 | , ByRef a2 As ONEDRIVE_ACCOUNT_INFO) 2454 | If a1.accountName <> a2.accountName Then Exit Sub 2455 | If Not (a1.isValid And a2.isValid) Then Exit Sub 2456 | ' 2457 | If a1.iniDateTime = 0 Then a1.iniDateTime = FileDateTime(a1.iniPath) 2458 | If a2.iniDateTime = 0 Then a2.iniDateTime = FileDateTime(a2.iniPath) 2459 | ' 2460 | a1.isValid = (a1.iniDateTime > a2.iniDateTime) 2461 | a2.isValid = Not a1.isValid 2462 | End Sub 2463 | 2464 | '******************************************************************************* 2465 | 'Utility for reading folder information for all the OneDrive accounts 2466 | '******************************************************************************* 2467 | Private Sub ReadODAccountsInfo(ByRef accountsInfo As ONEDRIVE_ACCOUNTS_INFO) 2468 | Const ps As String = PATH_SEPARATOR 2469 | Dim folderPath As Variant 2470 | Dim i As Long 2471 | Dim hasIniFile As Boolean 2472 | Dim collFolders As Collection: Set collFolders = GetODAccountDirs() 2473 | ' 2474 | accountsInfo.pCount = 0 2475 | accountsInfo.isSet = False 2476 | ' 2477 | If collFolders Is Nothing Then Exit Sub 2478 | If collFolders.Count > 0 Then ReDim accountsInfo.arr(1 To collFolders.Count) 2479 | ' 2480 | For Each folderPath In collFolders 2481 | i = i + 1 2482 | With accountsInfo.arr(i) 2483 | .folderPath = folderPath 2484 | .accountName = Mid$(folderPath, InStrRev(folderPath, ps) + 1) 2485 | .isPersonal = (.accountName = "Personal") 2486 | If Not .isPersonal Then 2487 | .accountIndex = CLng(Right$(.accountName, 1)) 2488 | End If 2489 | .globalPath = .folderPath & ps & "global.ini" 2490 | .cID = GetTagValue(.globalPath, "cid = ") 2491 | .iniPath = .folderPath & ps & .cID & ".ini" 2492 | #If Mac Then 'Avoid Mac File Access Request 2493 | hasIniFile = (Dir(.iniPath & "*") = .cID & ".ini") 2494 | #Else 2495 | hasIniFile = IsFile(.iniPath) 2496 | #End If 2497 | If hasIniFile Then 2498 | .datPath = .folderPath & ps & .cID & ".dat" 2499 | .dbPath = .folderPath & ps & "SyncEngineDatabase.db" 2500 | .groupPath = .folderPath & ps & "GroupFolders.ini" 2501 | .clientPath = .folderPath & ps & "ClientPolicy.ini" 2502 | #If Mac Then 'Avoid Mac File Access Request 2503 | .hasDatFile = (Dir(.datPath & "*") = .cID & ".dat") 2504 | #Else 2505 | .hasDatFile = IsFile(.datPath) 2506 | #End If 2507 | .isValid = True 2508 | End If 2509 | If Not .isValid Then i = i - 1 2510 | End With 2511 | Next folderPath 2512 | With accountsInfo 2513 | If i > 0 And i < collFolders.Count Then ReDim Preserve .arr(1 To i) 2514 | .pCount = i 2515 | .isSet = True 2516 | End With 2517 | End Sub 2518 | 2519 | '******************************************************************************* 2520 | 'Utility for reading all OneDrive account folder paths within OneDrive Settings 2521 | '******************************************************************************* 2522 | Private Function GetODAccountDirs() As Collection 2523 | Dim collSettings As Collection: Set collSettings = GetODSettingsDirs() 2524 | Dim settingsPath As Variant 2525 | ' 2526 | #If Mac Then 'Grant access, if needed, to all possbile folders, in batch 2527 | Dim arrDirs() As Variant: ReDim arrDirs(0 To collSettings.Count * 11) 2528 | Dim i As Long 2529 | ' 2530 | arrDirs(i) = GetCloudPath() 2531 | For Each settingsPath In collSettings 2532 | For i = i + 1 To i + 9 2533 | arrDirs(i) = settingsPath & "Business" & i Mod 11 2534 | Next i 2535 | arrDirs(i) = settingsPath 2536 | i = i + 1 2537 | arrDirs(i) = settingsPath & "Personal" 2538 | Next settingsPath 2539 | If Not GrantAccessToMultipleFiles(arrDirs) Then Exit Function 2540 | #End If 2541 | ' 2542 | Dim folderPath As Variant 2543 | Dim folderName As String 2544 | Dim collFolders As New Collection 2545 | ' 2546 | For Each settingsPath In collSettings 2547 | folderName = Dir(settingsPath, vbDirectory) 2548 | Do While LenB(folderName) > 0 2549 | If folderName Like "Business#" Or folderName = "Personal" Then 2550 | folderPath = settingsPath & folderName 2551 | If IsFolder(CStr(folderPath)) Then collFolders.Add folderPath 2552 | End If 2553 | folderName = Dir 2554 | Loop 2555 | Next settingsPath 2556 | Set GetODAccountDirs = collFolders 2557 | End Function 2558 | 2559 | '******************************************************************************* 2560 | 'Utility returning all possible OneDrive Settings folders 2561 | '******************************************************************************* 2562 | Private Function GetODSettingsDirs() As Collection 2563 | Set GetODSettingsDirs = New Collection 2564 | With GetODSettingsDirs 2565 | #If Mac Then 2566 | Const settingsPath = "Library/Application Support/OneDrive/settings/" 2567 | Const dataPath = "Library/Containers/com.microsoft.OneDrive-mac/Data/" 2568 | .Add GetUserPath() & settingsPath 2569 | .Add GetUserPath() & dataPath & settingsPath 2570 | #Else 2571 | .Add BuildPath(Environ$("LOCALAPPDATA"), "Microsoft\OneDrive\settings\") 2572 | #End If 2573 | End With 2574 | End Function 2575 | 2576 | '******************************************************************************* 2577 | 'Returns the index of the newly added OneDrive provider struct 2578 | '******************************************************************************* 2579 | Private Function AddProvider() As Long 2580 | With m_providers 2581 | If .pCount = 0 Then Erase .arr 2582 | .pCount = .pCount + 1 2583 | ReDim Preserve .arr(1 To .pCount) 2584 | AddProvider = .pCount 2585 | End With 2586 | End Function 2587 | 2588 | '******************************************************************************* 2589 | 'Adds all providers for a Business OneDrive account 2590 | '******************************************************************************* 2591 | Private Sub AddBusinessProviders(ByRef aInfo As ONEDRIVE_ACCOUNT_INFO) 2592 | Dim bytes() As Byte: ReadBytes aInfo.iniPath, bytes 2593 | Dim iniText As String: iniText = bytes 2594 | Dim lineText As Variant 2595 | Dim tempMount As String 2596 | Dim mainMount As String 2597 | Dim syncID As String 2598 | Dim mainSyncID As String 2599 | Dim tempURL As String 2600 | Dim cSignature As String 2601 | Dim oDirs As DirsInfo 2602 | Dim cParents As Collection 2603 | Dim cPending As New Collection 2604 | Dim canAdd As Boolean 2605 | Dim collTags As New Collection 2606 | Dim arrTags() As Variant 2607 | Dim vTag As Variant 2608 | Dim tempColl As Collection 2609 | Dim collSortedLines As New Collection 2610 | Dim i As Long, j As Long 2611 | Dim targetCount As Long 2612 | ' 2613 | #If Mac Then 2614 | iniText = ConvertText(iniText, codeUTF16LE, codeUTF8, True) 2615 | #End If 2616 | arrTags = Array("libraryScope", "libraryFolder", "AddedScope") 2617 | For Each vTag In arrTags 2618 | collTags.Add New Collection, vTag 2619 | Next vTag 2620 | For Each lineText In Split(iniText, vbNewLine) 2621 | i = InStr(1, lineText, " = ", vbBinaryCompare) 2622 | If i > 0 Then 2623 | vTag = Left$(lineText, i - 1) 2624 | Select Case vTag 2625 | Case arrTags(0), arrTags(1), arrTags(2) 2626 | i = i + 3 2627 | j = InStr(i, lineText, " ", vbBinaryCompare) 2628 | collTags(vTag).Add lineText, Mid$(lineText, i, j - i) 2629 | End Select 2630 | End If 2631 | Next lineText 2632 | On Error Resume Next 2633 | For Each tempColl In collTags 2634 | i = 0 2635 | targetCount = collSortedLines.Count + tempColl.Count 2636 | Do 2637 | collSortedLines.Add tempColl(CStr(i)) 2638 | i = i + 1 2639 | Loop Until collSortedLines.Count = targetCount 2640 | Next tempColl 2641 | On Error GoTo 0 2642 | For Each lineText In collSortedLines 2643 | Dim parts() As String: parts = SplitIniLine(lineText) 2644 | Select Case parts(0) 2645 | Case "libraryScope" 2646 | tempMount = parts(14) 2647 | syncID = parts(16) 2648 | canAdd = (LenB(tempMount) > 0) 2649 | If parts(2) = "0" Then 2650 | mainMount = tempMount 2651 | mainSyncID = syncID 2652 | tempURL = GetUrlNamespace(aInfo.clientPath) 2653 | Else 2654 | cSignature = "_" & parts(12) & parts(10) 2655 | tempURL = GetUrlNamespace(aInfo.clientPath, cSignature) 2656 | End If 2657 | cPending.Add tempURL, parts(2) 2658 | Case "libraryFolder" 2659 | If oDirs.dirCount = 0 Then ReadODDirs aInfo, oDirs 2660 | tempMount = parts(6) 2661 | tempURL = cPending(parts(3)) 2662 | syncID = parts(9) 2663 | Dim tempID As String: tempID = parts(4) 2664 | Dim tempFolder As String: tempFolder = vbNullString 2665 | If aInfo.hasDatFile Then tempID = Split(tempID, "+")(0) 2666 | On Error Resume Next 2667 | Do 2668 | i = oDirs.idToIndex(tempID) 2669 | If Err.Number <> 0 Then Exit Do 2670 | With oDirs.arrDirs(i) 2671 | tempFolder = .dirName & "/" & tempFolder 2672 | tempID = .parentID 2673 | End With 2674 | Loop 2675 | On Error GoTo 0 2676 | canAdd = (LenB(tempFolder) > 0) 2677 | tempURL = tempURL & tempFolder 2678 | Case "AddedScope" 2679 | If LenB(mainMount) = 0 Then Err.Raise vbErrInvalidFormatInResourceFile 2680 | If oDirs.dirCount = 0 Then ReadODDirs aInfo, oDirs 2681 | tempID = parts(3) 2682 | tempFolder = vbNullString 2683 | On Error Resume Next 2684 | Do 2685 | i = oDirs.idToIndex(tempID) 2686 | If Err.Number <> 0 Then Exit Do 2687 | With oDirs.arrDirs(i) 2688 | tempFolder = .dirName & PATH_SEPARATOR & tempFolder 2689 | tempID = .parentID 2690 | End With 2691 | Loop 2692 | On Error GoTo 0 2693 | tempMount = mainMount & PATH_SEPARATOR & tempFolder 2694 | syncID = mainSyncID 2695 | tempURL = parts(11) 2696 | If tempURL = " " Or LenB(tempURL) = 0 Then 2697 | tempURL = vbNullString 2698 | Else 2699 | tempURL = tempURL & "/" 2700 | End If 2701 | cSignature = "_" & parts(9) & parts(7) & parts(10) 2702 | tempURL = GetUrlNamespace(aInfo.clientPath, cSignature) & tempURL 2703 | canAdd = True 2704 | Case Else 2705 | Exit For 2706 | End Select 2707 | If canAdd Then 2708 | With m_providers.arr(AddProvider()) 2709 | .webPath = tempURL 2710 | .mountPoint = BuildPath(tempMount, vbNullString) 2711 | .isBusiness = True 2712 | .isMain = (tempMount = mainMount) 2713 | .accountIndex = aInfo.accountIndex 2714 | If syncID = mainSyncID Then 2715 | .baseMount = mainMount 2716 | Else 2717 | .baseMount = tempMount 2718 | End If 2719 | .syncID = syncID 2720 | End With 2721 | End If 2722 | Next lineText 2723 | End Sub 2724 | 2725 | '******************************************************************************* 2726 | 'Splits a cid.ini file into space delimited parts 2727 | '******************************************************************************* 2728 | Private Function SplitIniLine(ByVal lineText As String) As String() 2729 | Dim i As Long 2730 | Dim j As Long 2731 | Dim k As Long 2732 | Dim res() As String: ReDim res(0 To 20) 2733 | Dim v As Variant 2734 | Dim s As String 2735 | Dim c As Long: c = Len(lineText) 2736 | ' 2737 | i = InStr(1, lineText, " ") 2738 | res(0) = Left$(lineText, i - 1) 2739 | Do 2740 | Do 2741 | i = i + 1 2742 | s = Mid$(lineText, i, 1) 2743 | Loop Until s <> " " 2744 | If i > c Then Exit Do 2745 | If s = """" Then 2746 | i = i + 1 2747 | j = InStr(i, lineText, """") 2748 | Else 2749 | j = InStr(i + 1, lineText, " ") 2750 | End If 2751 | If j = 0 Then j = c + 1 2752 | k = k + 1 2753 | If k > UBound(res) Then ReDim Preserve res(0 To k) 2754 | res(k) = Mid$(lineText, i, j - i) 2755 | i = j 2756 | Loop Until j > c 2757 | ReDim Preserve res(0 To k) 2758 | SplitIniLine = res 2759 | End Function 2760 | 2761 | '******************************************************************************* 2762 | 'Returns the URLNamespace from a provider's ClientPolicy*.ini file 2763 | '******************************************************************************* 2764 | Private Function GetUrlNamespace(ByRef clientPath As String _ 2765 | , Optional ByVal cSignature As String) As String 2766 | Dim cPath As String 2767 | ' 2768 | cPath = Left$(clientPath, Len(clientPath) - 4) & cSignature & ".ini" 2769 | GetUrlNamespace = GetTagValue(cPath, "DavUrlNamespace = ") 2770 | End Function 2771 | 2772 | '******************************************************************************* 2773 | 'Returns the required value from an ini file text line based on given tag 2774 | '******************************************************************************* 2775 | Private Function GetTagValue(ByRef filePath As String _ 2776 | , ByRef vTag As String) As String 2777 | Dim bytes() As Byte 2778 | Dim fText As String 2779 | Dim i As Long 2780 | Dim j As Long 2781 | ' 2782 | On Error Resume Next 2783 | ReadBytes filePath, bytes 2784 | fText = bytes 2785 | #If Mac Then 2786 | If Err.Number = 0 Then 2787 | fText = ConvertText(fText, codeUTF16LE, codeUTF8, True) 2788 | Else 'Open failed, try AppleScript with no text conversion needed 2789 | Dim tempPath As String 2790 | tempPath = MacScript("return path to startup disk as string") _ 2791 | & Replace(Mid$(filePath, 2), PATH_SEPARATOR, ":") 2792 | fText = MacScript("return read file """ & tempPath & """ as string") 2793 | End If 2794 | #End If 2795 | On Error GoTo 0 2796 | ' 2797 | If Len(fText) = 0 Then Exit Function 2798 | i = InStr(1, fText, vTag) 2799 | If i = 0 Then Exit Function 2800 | i = i + Len(vTag) 2801 | ' 2802 | j = InStr(i + 1, fText, vbNewLine) 2803 | If j = 0 Then 2804 | GetTagValue = Mid$(fText, i) 2805 | Else 2806 | GetTagValue = Mid$(fText, i, j - i) 2807 | End If 2808 | End Function 2809 | 2810 | '******************************************************************************* 2811 | 'Adds all providers for a Personal OneDrive account 2812 | '******************************************************************************* 2813 | Private Sub AddPersonalProviders(ByRef aInfo As ONEDRIVE_ACCOUNT_INFO) 2814 | Dim mainURL As String 2815 | Dim libText As String 2816 | Dim libParts() As String 2817 | Dim mainMount As String 2818 | Dim bytes() As Byte 2819 | Dim groupText As String 2820 | Dim syncID As String 2821 | Dim lineText As Variant 2822 | Dim cID As String 2823 | Dim i As Long 2824 | Dim relPath As String 2825 | Dim folderID As String 2826 | Dim oDirs As DirsInfo 2827 | ' 2828 | ReadBytes aInfo.groupPath, bytes 2829 | groupText = bytes 2830 | ' 2831 | mainURL = GetUrlNamespace(aInfo.clientPath) & "/" 2832 | libText = GetTagValue(aInfo.iniPath, "library = ") 2833 | If LenB(libText) > 0 Then 2834 | libParts = SplitIniLine(libText) 2835 | mainMount = libParts(7) 2836 | syncID = libParts(9) 2837 | Else 2838 | libText = GetTagValue(aInfo.iniPath, "libraryScope = ") 2839 | libParts = SplitIniLine(libText) 2840 | mainMount = libParts(12) 2841 | syncID = libParts(7) 2842 | End If 2843 | ' 2844 | With m_providers.arr(AddProvider()) 2845 | .webPath = mainURL & aInfo.cID & "/" 2846 | .mountPoint = mainMount & PATH_SEPARATOR 2847 | .baseMount = mainMount 2848 | .syncID = syncID 2849 | End With 2850 | #If Mac Then 2851 | groupText = ConvertText(groupText, codeUTF16LE, codeUTF8, True) 2852 | #End If 2853 | For Each lineText In Split(groupText, vbNewLine) 2854 | If InStr(1, lineText, "_BaseUri", vbTextCompare) > 0 Then 2855 | cID = LCase$(Mid$(lineText, InStrRev(lineText, "/") + 1)) 2856 | i = InStr(1, cID, "!") 2857 | If i > 0 Then cID = Left$(cID, i - 1) 2858 | Else 2859 | i = InStr(1, lineText, "_Path", vbTextCompare) 2860 | If i > 0 Then 2861 | relPath = Mid$(lineText, i + 8) 2862 | folderID = Left$(lineText, i - 1) 2863 | If oDirs.dirCount = 0 Then ReadODDirs aInfo, oDirs 2864 | With m_providers.arr(AddProvider()) 2865 | .webPath = mainURL & cID & "/" & relPath & "/" 2866 | relPath = oDirs.arrDirs(oDirs.idToIndex(folderID)).dirName 2867 | .mountPoint = BuildPath(mainMount, relPath & "/") 2868 | .baseMount = mainMount 2869 | .syncID = syncID 2870 | End With 2871 | End If 2872 | End If 2873 | Next lineText 2874 | End Sub 2875 | 2876 | '******************************************************************************* 2877 | 'Utility - Retrieves all folders from an OneDrive account 2878 | '******************************************************************************* 2879 | Private Sub ReadODDirs(ByRef aInfo As ONEDRIVE_ACCOUNT_INFO _ 2880 | , ByRef outdirs As DirsInfo) 2881 | If aInfo.hasDatFile Then 2882 | ReadDirsFromDat aInfo.datPath, outdirs 2883 | End If 2884 | If outdirs.dirCount = 0 Then 2885 | ReadDirsFromDB aInfo.dbPath, aInfo.isPersonal, outdirs 2886 | End If 2887 | End Sub 2888 | 2889 | '******************************************************************************* 2890 | 'Utility - Retrieves all folders from an OneDrive user dat file 2891 | '******************************************************************************* 2892 | Private Sub ReadDirsFromDat(ByRef filePath As String, ByRef outdirs As DirsInfo) 2893 | Dim fileNumber As Long: fileNumber = FreeFile() 2894 | ' 2895 | Open filePath For Binary Access Read As #fileNumber 2896 | Dim size As Long: size = LOF(fileNumber) 2897 | If size = 0 Then GoTo CloseFile 2898 | ' 2899 | Const hCheckSize As Long = 8 2900 | Const idSize As Long = 39 2901 | Const fNameOffset As Long = 121 2902 | Const checkToName As Long = hCheckSize + idSize + fNameOffset + fNameOffset 2903 | Const chunkSize As Long = &H100000 '1MB 2904 | Const maxDirName As Long = 255 2905 | #If Mac Then 2906 | Const nameEnd As String = vbNullChar & vbNullChar 2907 | #Else 2908 | Const nameEnd As String = vbNullChar 2909 | #End If 2910 | ' 2911 | Dim b(1 To chunkSize) As Byte 2912 | Dim s As String 2913 | Dim lastRecord As Long 2914 | Dim i As Long 2915 | Dim lastFileChange As Date 2916 | Dim currFileChange As Date 2917 | Dim stepSize As Long 2918 | Dim bytes As Long 2919 | Dim dirID As String 2920 | Dim parentID As String 2921 | Dim dirName As String 2922 | Dim idPattern As String 2923 | Dim vbNullByte As String: vbNullByte = ChrB$(0) 2924 | Dim hFolder As String: hFolder = ChrB$(2) 'x02 2925 | Dim hCheck As String * 4: MidB$(hCheck, 1) = ChrB$(1) 'x01000000 2926 | ' 2927 | idPattern = Replace(Space$(12), " ", "[a-fA-F0-9]") & "*" 2928 | For stepSize = 16 To 8 Step -8 2929 | lastFileChange = 0 2930 | Do 2931 | i = 0 2932 | currFileChange = FileDateTime(filePath) 2933 | If currFileChange > lastFileChange Then 2934 | With outdirs 2935 | Set .idToIndex = New Collection 2936 | .dirCount = 0 2937 | .dirUBound = 256 2938 | ReDim .arrDirs(1 To .dirUBound) 2939 | End With 2940 | lastFileChange = currFileChange 2941 | lastRecord = 1 2942 | End If 2943 | Get fileNumber, lastRecord, b 2944 | s = b 2945 | i = InStrB(stepSize + 1, s, hCheck) 2946 | Do While i > 0 And i < chunkSize - checkToName 2947 | If MidB$(s, i - stepSize, 1) = hFolder Then 2948 | i = i + hCheckSize 2949 | bytes = Clamp(InStrB(i, s, vbNullByte) - i, 0, idSize) 2950 | dirID = StrConv(MidB$(s, i, bytes), vbUnicode) 2951 | ' 2952 | i = i + idSize 2953 | bytes = Clamp(InStrB(i, s, vbNullByte) - i, 0, idSize) 2954 | parentID = StrConv(MidB$(s, i, bytes), vbUnicode) 2955 | ' 2956 | i = i + fNameOffset 2957 | If dirID Like idPattern And parentID Like idPattern Then 2958 | bytes = InStr((i + 1) \ 2, s, nameEnd) * 2 - i - 1 2959 | #If Mac Then 2960 | Do While bytes Mod 4 > 0 And bytes > 0 2961 | If bytes > maxDirName * 4 Then 2962 | bytes = maxDirName * 4 2963 | Exit Do 2964 | End If 2965 | bytes = InStr((i + bytes + 1) \ 2 + 1, s, nameEnd) _ 2966 | * 2 - i - 1 2967 | Loop 2968 | #Else 2969 | If bytes > maxDirName * 2 Then bytes = maxDirName * 2 2970 | #End If 2971 | If bytes < 0 Or i + bytes - 1 > chunkSize Then 'Next chunk 2972 | i = i - checkToName 2973 | Exit Do 2974 | End If 2975 | dirName = MidB$(s, i, bytes) 2976 | #If Mac Then 2977 | dirName = ConvertText(dirName, codeUTF16LE _ 2978 | , codeUTF32LE, True) 2979 | #End If 2980 | With outdirs 2981 | .dirCount = .dirCount + 1 2982 | If .dirCount > .dirUBound Then 2983 | .dirUBound = .dirUBound * 2 2984 | ReDim Preserve .arrDirs(1 To .dirUBound) 2985 | End If 2986 | .idToIndex.Add .dirCount, dirID 2987 | With outdirs.arrDirs(.dirCount) 2988 | .dirID = dirID 2989 | .dirName = dirName 2990 | .parentID = parentID 2991 | End With 2992 | End With 2993 | End If 2994 | End If 2995 | i = InStrB(i + 1, s, hCheck) 2996 | Loop 2997 | lastRecord = lastRecord + chunkSize - stepSize 2998 | If i > stepSize Then 2999 | lastRecord = lastRecord - chunkSize + (i \ 2) * 2 3000 | End If 3001 | Loop Until lastRecord > size 3002 | If outdirs.dirCount > 0 Then Exit For 3003 | Next stepSize 3004 | If outdirs.dirCount > 0 Then 3005 | ReDim Preserve outdirs.arrDirs(1 To outdirs.dirCount) 3006 | End If 3007 | CloseFile: 3008 | Close #fileNumber 3009 | End Sub 3010 | Private Function Clamp(ByVal v As Long, ByVal lowB As Long, uppB As Long) As Long 3011 | If v < lowB Then 3012 | Clamp = lowB 3013 | ElseIf v > uppB Then 3014 | Clamp = uppB 3015 | Else 3016 | Clamp = v 3017 | End If 3018 | End Function 3019 | 3020 | '******************************************************************************* 3021 | 'Utility - Retrieves all folders from an OneDrive user database file 3022 | '******************************************************************************* 3023 | Private Sub ReadDirsFromDB(ByRef filePath As String _ 3024 | , ByVal isPersonal As Boolean _ 3025 | , ByRef outdirs As DirsInfo) 3026 | If Not IsFile(filePath) Then Exit Sub 3027 | Dim fileNumber As Long: fileNumber = FreeFile() 3028 | ' 3029 | Open filePath For Binary Access Read As #fileNumber 3030 | Dim size As Long: size = LOF(fileNumber) 3031 | If size = 0 Then GoTo CloseFile 3032 | ' 3033 | Const chunkSize As Long = &H100000 '1MB 3034 | Const minName As Long = 15 3035 | Const maxSigByte As Byte = 9 3036 | Const maxHeader As Long = 21 3037 | Const minIDSize As Long = 12 3038 | Const maxIDSize As Long = 48 3039 | Const minThreeIDSizes As Long = minIDSize * 3 3040 | Const maxThreeIDSizes As Long = maxIDSize * 3 3041 | Const leadingBuff As Long = maxHeader + maxThreeIDSizes 3042 | Const headBytesOffset As Long = 15 3043 | Const bangCode As Long = 33 'Asc("!") 3044 | Dim curlyStart As String: curlyStart = ChrW$(&H7B22) '"{ 3045 | Dim quoteB As String: quoteB = ChrB$(&H22) '" 3046 | Dim bangB As String: bangB = ChrB$(bangCode) '! 3047 | Dim sig As String 3048 | Dim b(1 To chunkSize) As Byte 3049 | Dim s As String 3050 | Dim lastRecord As Long 3051 | Dim i As Long 3052 | Dim j As Long 3053 | Dim k As Long 3054 | Dim idSize(1 To 4) As Long 3055 | Dim nameSize As Long 3056 | Dim dirID As String 3057 | Dim parentID As String 3058 | Dim dirName As String 3059 | Dim nameEnd As Long 3060 | Dim nameStart As Long 3061 | Dim isASCII As Boolean 3062 | Dim mustAdd As Boolean 3063 | Dim idPattern As String 3064 | ' 3065 | idPattern = Replace(Space$(12), " ", "[a-fA-F0-9]") 3066 | If isPersonal Then 3067 | sig = bangB 3068 | idPattern = "*" & idPattern & "![a-fA-F0-9]*" 3069 | Else 3070 | sig = curlyStart 3071 | idPattern = idPattern & "*" 3072 | End If 3073 | Do 3074 | Dim currFileChange As Date: currFileChange = FileDateTime(filePath) 3075 | Dim lastFileChange As Date 3076 | ' 3077 | i = 0 3078 | If currFileChange > lastFileChange Then 3079 | With outdirs 3080 | Set .idToIndex = New Collection 3081 | .dirCount = 0 3082 | .dirUBound = 256 3083 | ReDim .arrDirs(1 To .dirUBound) 3084 | End With 3085 | lastFileChange = currFileChange 3086 | lastRecord = 1 3087 | End If 3088 | Get fileNumber, lastRecord, b 3089 | s = b 3090 | i = InStrB(1, s, sig) 3091 | Do While i > 0 3092 | If isPersonal Then 3093 | For j = i - 1 To i - maxIDSize Step -1 3094 | If j = 0 Then GoTo NextSig 3095 | If b(j) < bangCode Then Exit For 3096 | Next j 3097 | If (j < maxHeader) Or (i - j < minIDSize) Then GoTo NextSig 3098 | Else 3099 | j = InStrB(i + 2, s, quoteB) 3100 | If j = 0 Then Exit Do 'Next chunk 3101 | idSize(4) = j - i + 1 3102 | If idSize(4) > maxIDSize Then GoTo NextSig 3103 | For j = i - 1 To i - maxThreeIDSizes Step -1 3104 | If j = 0 Then GoTo NextSig 3105 | If b(j) < bangCode Then Exit For 3106 | Next j 3107 | If j < maxHeader Then GoTo NextSig 3108 | idSize(1) = i - j - 1 'ID 1+2+3 3109 | If idSize(1) < minThreeIDSizes Then GoTo NextSig 3110 | End If 3111 | ' 3112 | k = j + 1 'ID1 Start 3113 | For j = j To j - headBytesOffset + 1 Step -1 3114 | If b(j) > maxSigByte Then GoTo NextSig 3115 | Next j 3116 | If (b(j) <= maxSigByte) And (b(j - 1) < &H80) Then j = j - 1 3117 | If b(j) < minName Then j = j - 1 3118 | ' 3119 | nameSize = b(j) 3120 | If nameSize Mod 2 = 0 Then GoTo NextSig 3121 | nameSize = (nameSize - 13) / 2 3122 | If b(j - 1) > &H7F Then 3123 | nameSize = (b(j - 1) - &H80) * &H40 + nameSize 3124 | j = j - 1 3125 | End If 3126 | If j < 5 Then GoTo NextSig 3127 | If (nameSize < 1) Or (b(j - 4) = 0) Then GoTo NextSig 3128 | ' 3129 | If isPersonal Then 3130 | idSize(4) = (b(j - 1) - 13) / 2 3131 | idSize(3) = (b(j - 2) - 13) / 2 3132 | idSize(2) = (b(j - 3) - 13) / 2 3133 | idSize(1) = (b(j - 4) - 13) / 2 3134 | nameStart = k + idSize(1) + idSize(2) + idSize(3) + idSize(4) 3135 | Else 3136 | If b(j - 1) <> idSize(4) * 2 + 13 Then GoTo NextSig 3137 | idSize(3) = (b(j - 2) - 13) / 2 3138 | idSize(2) = (b(j - 3) - 13) / 2 3139 | idSize(1) = idSize(1) - idSize(2) - idSize(3) 3140 | nameStart = i + idSize(4) 3141 | End If 3142 | For j = 1 To 4 3143 | If (idSize(j) < minIDSize) _ 3144 | Or (idSize(j) > maxIDSize) Then GoTo NextSig 3145 | Next j 3146 | ' 3147 | nameEnd = nameStart + nameSize - 1 3148 | If nameEnd > chunkSize Then Exit Do 'Next chunk 3149 | ' 3150 | dirID = StrConv(MidB$(s, k, idSize(1)), vbUnicode) 3151 | If Not dirID Like idPattern Then GoTo NextSig 3152 | ' 3153 | k = k + idSize(1) 3154 | parentID = StrConv(MidB$(s, k, idSize(2)), vbUnicode) 3155 | If Not parentID Like idPattern Then GoTo NextSig 3156 | ' 3157 | If isPersonal Then 3158 | k = k + idSize(2) 3159 | If Not StrConv(MidB$(s, k, idSize(3)), vbUnicode) _ 3160 | Like idPattern Then GoTo NextSig 3161 | If Not StrConv(MidB$(s, k + idSize(3), idSize(4)), vbUnicode) _ 3162 | Like idPattern Then GoTo NextSig 3163 | End If 3164 | ' 3165 | On Error Resume Next 3166 | j = outdirs.idToIndex(dirID) 3167 | mustAdd = (Err.Number <> 0) 3168 | On Error GoTo 0 3169 | ' 3170 | If mustAdd Then 3171 | With outdirs 3172 | .dirCount = .dirCount + 1 3173 | If .dirCount > .dirUBound Then 3174 | .dirUBound = .dirUBound * 2 3175 | ReDim Preserve .arrDirs(1 To .dirUBound) 3176 | End If 3177 | .idToIndex.Add .dirCount, dirID 3178 | j = .dirCount 3179 | End With 3180 | With outdirs.arrDirs(j) 3181 | .dirName = MidB$(s, nameStart, nameSize) 3182 | .isNameASCII = True 3183 | For k = nameStart To nameEnd 3184 | If b(k) > &H7F Then 3185 | .isNameASCII = False 3186 | Exit For 3187 | End If 3188 | Next k 3189 | If .isNameASCII Then 3190 | .dirName = StrConv(.dirName, vbUnicode) 3191 | Else 3192 | .dirName = ConvertText(.dirName, codeUTF16LE, codeUTF8) 3193 | End If 3194 | .dirID = dirID 3195 | .parentID = parentID 3196 | End With 3197 | Else 3198 | With outdirs.arrDirs(j) 3199 | If (Not .isNameASCII) Or (Len(.dirName) < nameSize) Then 3200 | dirName = MidB$(s, nameStart, nameSize) 3201 | isASCII = True 3202 | For k = nameStart To nameEnd 3203 | If b(k) > &H7F Then 3204 | isASCII = False 3205 | Exit For 3206 | End If 3207 | Next k 3208 | If isASCII Then 3209 | .dirName = StrConv(dirName, vbUnicode) 3210 | Else 3211 | .dirName = ConvertText(dirName, codeUTF16LE, codeUTF8) 3212 | End If 3213 | .isNameASCII = isASCII 3214 | End If 3215 | End With 3216 | End If 3217 | i = nameEnd 3218 | NextSig: 3219 | i = InStrB(i + 1, s, sig) 3220 | Loop 3221 | If i = 0 Then 3222 | lastRecord = lastRecord + chunkSize - leadingBuff 3223 | ElseIf i > leadingBuff Then 3224 | lastRecord = lastRecord + i - leadingBuff 3225 | Else 3226 | lastRecord = lastRecord + i 3227 | End If 3228 | Loop Until lastRecord > size 3229 | ReDim Preserve outdirs.arrDirs(1 To outdirs.dirCount) 3230 | CloseFile: 3231 | Close #fileNumber 3232 | End Sub 3233 | 3234 | '******************************************************************************* 3235 | 'Checks if a path indicates a file path 3236 | 'Note that if C:\Test\1.txt is valid then C:\Test\\///1.txt will also be valid 3237 | 'Most VBA methods consider valid any path separators with multiple characters 3238 | '******************************************************************************* 3239 | Public Function IsFile(ByRef filePath As String) As Boolean 3240 | #If Mac Then 3241 | Const maxFileLen As Long = 259 'To be updated 3242 | #Else 3243 | Const maxFileLen As Long = 259 3244 | #End If 3245 | Const errBadFileNameOrNumber As Long = 52 3246 | Dim fAttr As VbFileAttribute 3247 | ' 3248 | On Error Resume Next 3249 | fAttr = GetAttr(filePath) 3250 | If Err.Number = errBadFileNameOrNumber Then 'Unicode characters 3251 | #If Mac Then 3252 | 3253 | #Else 3254 | IsFile = GetFSO().FileExists(filePath) 3255 | #End If 3256 | ElseIf Err.Number = 0 Then 3257 | IsFile = Not CBool(fAttr And vbDirectory) 3258 | ElseIf Len(filePath) > maxFileLen Then 3259 | #If Mac Then 3260 | 3261 | #Else 3262 | If Left$(filePath, 4) = "\\?\" Then 3263 | IsFile = GetFSO().FileExists(filePath) 3264 | ElseIf Left$(filePath, 2) = "\\" Then 3265 | IsFile = GetFSO().FileExists("\\?\UNC" & Mid$(filePath, 2)) 3266 | Else 3267 | IsFile = GetFSO().FileExists("\\?\" & filePath) 3268 | End If 3269 | #End If 3270 | End If 3271 | On Error GoTo 0 3272 | End Function 3273 | '******************************************************************************* 3274 | 'Checks if a path indicates a folder path 3275 | 'Note that if C:\Test\Demo is valid then C:\Test\\///Demo will also be valid 3276 | 'Most VBA methods consider valid any path separators with multiple characters 3277 | '******************************************************************************* 3278 | Public Function IsFolder(ByRef folderPath As String) As Boolean 3279 | #If Mac Then 3280 | Const maxDirLen As Long = 247 'To be updated 3281 | #Else 3282 | Const maxDirLen As Long = 247 3283 | #End If 3284 | Const errBadFileNameOrNumber As Long = 52 3285 | Dim fAttr As VbFileAttribute 3286 | ' 3287 | On Error Resume Next 3288 | fAttr = GetAttr(folderPath) 3289 | If Err.Number = errBadFileNameOrNumber Then 'Unicode characters 3290 | #If Mac Then 3291 | 3292 | #Else 3293 | IsFolder = GetFSO().FolderExists(folderPath) 3294 | #End If 3295 | ElseIf Err.Number = 0 Then 3296 | IsFolder = CBool(fAttr And vbDirectory) 3297 | ElseIf Len(folderPath) > maxDirLen Then 3298 | #If Mac Then 3299 | 3300 | #Else 3301 | If Left$(folderPath, 4) = "\\?\" Then 3302 | IsFolder = GetFSO().FolderExists(folderPath) 3303 | ElseIf Left$(folderPath, 2) = "\\" Then 3304 | IsFolder = GetFSO().FolderExists("\\?\UNC" & Mid$(folderPath, 2)) 3305 | Else 3306 | IsFolder = GetFSO().FolderExists("\\?\" & folderPath) 3307 | End If 3308 | #End If 3309 | End If 3310 | On Error GoTo 0 3311 | End Function 3312 | 3313 | '******************************************************************************* 3314 | 'Checks if the contents of a folder can be edited 3315 | '******************************************************************************* 3316 | Public Function IsFolderEditable(ByRef folderPath As String) As Boolean 3317 | Dim tempFolder As String 3318 | Dim fixedPath As String: fixedPath = BuildPath(folderPath, vbNullString) 3319 | ' 3320 | Do 3321 | tempFolder = fixedPath & Rnd() 3322 | Loop Until Not IsFolder(tempFolder) 3323 | ' 3324 | On Error Resume Next 3325 | MkDir tempFolder 3326 | IsFolderEditable = (Err.Number = 0) 3327 | If IsFolderEditable Then RmDir tempFolder 3328 | On Error GoTo 0 3329 | End Function 3330 | 3331 | '******************************************************************************* 3332 | 'Moves (or renames) a file 3333 | '******************************************************************************* 3334 | Public Function MoveFile(ByRef sourcePath As String _ 3335 | , ByRef destinationPath As String) As Boolean 3336 | If LenB(sourcePath) = 0 Then Exit Function 3337 | If LenB(destinationPath) = 0 Then Exit Function 3338 | If Not IsFile(sourcePath) Then Exit Function 3339 | ' 3340 | On Error Resume Next 3341 | #If Mac Then 3342 | Dim fAttr As VbFileAttribute: fAttr = GetAttr(sourcePath) 3343 | If fAttr <> vbNormal Then SetAttr sourcePath, vbNormal 3344 | Err.Clear 3345 | #End If 3346 | ' 3347 | Name sourcePath As destinationPath 3348 | MoveFile = (Err.Number = 0) 3349 | ' 3350 | #If Mac Then 3351 | If fAttr <> vbNormal Then 'Restore attribute 3352 | If MoveFile Then 3353 | SetAttr destinationPath, fAttr 3354 | Else 3355 | SetAttr sourcePath, fAttr 3356 | End If 3357 | End If 3358 | #End If 3359 | On Error GoTo 0 3360 | End Function 3361 | 3362 | '******************************************************************************* 3363 | 'Moves (or renames) a folder 3364 | '******************************************************************************* 3365 | Public Function MoveFolder(ByRef sourcePath As String _ 3366 | , ByRef destinationPath As String) As Boolean 3367 | If LenB(sourcePath) = 0 Then Exit Function 3368 | If LenB(destinationPath) = 0 Then Exit Function 3369 | If Not IsFolder(sourcePath) Then Exit Function 3370 | If IsFolder(destinationPath) Then Exit Function 3371 | ' 3372 | 'The 'Name' statement can move a file across drives, but it can only rename 3373 | ' a directory or folder within the same drive. Try 'Name' first 3374 | On Error Resume Next 3375 | Name sourcePath As destinationPath 3376 | MoveFolder = (Err.Number = 0) 3377 | If MoveFolder Then Exit Function 3378 | On Error GoTo 0 3379 | ' 3380 | 'Try FSO if available 3381 | #If Windows Then 3382 | On Error Resume Next 3383 | GetFSO().MoveFolder sourcePath, destinationPath 3384 | If Err.Number = 0 Then 3385 | MoveFolder = True 3386 | Exit Function 3387 | End If 3388 | On Error GoTo 0 3389 | #End If 3390 | ' 3391 | 'If all else failed, first make a copy and then delete the source 3392 | If Not CopyFolder(sourcePath, destinationPath, True) Then 'Revert 3393 | DeleteFolder destinationPath, True 3394 | Exit Function 3395 | ElseIf Not DeleteFolder(sourcePath, True) Then 'Files might be open. Revert 3396 | CopyFolder destinationPath, sourcePath, ignoreFailedChildren:=True 3397 | DeleteFolder destinationPath, True 3398 | Exit Function 3399 | End If 3400 | ' 3401 | MoveFolder = True 3402 | End Function 3403 | 3404 | '******************************************************************************* 3405 | 'Returns the parent folder path for a given file or folder local path 3406 | '******************************************************************************* 3407 | Public Function ParentFolder(ByRef localPath As String) As String 3408 | Const ps As String = PATH_SEPARATOR 3409 | Dim fixedPath As String: fixedPath = FixPathSeparators(localPath) 3410 | Dim i As Long 3411 | ' 3412 | If Len(fixedPath) < 3 Then Exit Function 3413 | i = InStrRev(fixedPath, ps, Len(fixedPath) - 1) 3414 | If i < 2 Then Exit Function 3415 | ' 3416 | If Mid$(fixedPath, i - 1, 1) <> ps Then 3417 | ParentFolder = Left$(fixedPath, i - 1) 3418 | End If 3419 | End Function 3420 | 3421 | '******************************************************************************* 3422 | 'Reads a file into an array of Bytes 3423 | '******************************************************************************* 3424 | Public Sub ReadBytes(ByRef filePath As String, ByRef result() As Byte) 3425 | If Not IsFile(filePath) Then 3426 | Erase result 3427 | Exit Sub 3428 | End If 3429 | ' 3430 | Dim fileNumber As Long: fileNumber = FreeFile() 3431 | ' 3432 | Open filePath For Binary Access Read As #fileNumber 3433 | Dim size As Long: size = LOF(fileNumber) 3434 | If size > 0 Then 3435 | ReDim result(0 To size - 1) 3436 | Get fileNumber, 1, result 3437 | Else 3438 | Erase result 3439 | End If 3440 | Close #fileNumber 3441 | End Sub 3442 | 3443 | '******************************************************************************* 3444 | 'Creates a text file used for diagnosing OneDrive logic issues 3445 | '******************************************************************************* 3446 | Private Sub CreateODDiagnosticsFile() 3447 | Dim folderPath As String 3448 | Do 3449 | folderPath = BrowseForFolder(, "Choose target folder for diagnostics") 3450 | If LenB(folderPath) = 0 Then Exit Sub 3451 | If IsFolderEditable(folderPath) Then Exit Do 3452 | MsgBox "Please choose a folder with write access" 3453 | Loop 3454 | ' 3455 | Const vbTwoNewLines As String = vbNewLine & vbNewLine 3456 | Const fileName As String = "DiagnosticsOD.txt" 3457 | Dim accountsInfo As ONEDRIVE_ACCOUNTS_INFO 3458 | Dim fileNumber As Long: fileNumber = FreeFile() 3459 | Dim filePath As String: filePath = BuildPath(folderPath, fileName) 3460 | Dim res As String 3461 | Dim i As Long 3462 | Dim temp(0 To 2) As String 3463 | ' 3464 | #If Mac Then 3465 | temp(0) = "Mac" 3466 | #Else 3467 | temp(0) = "Win" 3468 | #End If 3469 | #If VBA7 Then 3470 | temp(1) = "VBA7" 3471 | #Else 3472 | temp(1) = "VBA6" 3473 | #End If 3474 | #If Win64 Then 3475 | temp(2) = "x64" 3476 | #Else 3477 | temp(2) = "x32" 3478 | #End If 3479 | res = Join(temp, " ") & vbTwoNewLines & String$(80, "-") & vbTwoNewLines 3480 | ' 3481 | ReadODAccountsInfo accountsInfo 3482 | For i = 1 To accountsInfo.pCount 'Check for unsynchronized accounts 3483 | Dim j As Long 3484 | For j = i + 1 To accountsInfo.pCount 3485 | ValidateAccounts accountsInfo.arr(i), accountsInfo.arr(j) 3486 | Next j 3487 | Next i 3488 | res = res & "Accounts found: " & accountsInfo.pCount & vbTwoNewLines 3489 | ' 3490 | For i = 1 To accountsInfo.pCount 3491 | With accountsInfo.arr(i) 3492 | res = res & "Name: " & .accountName & vbNewLine 3493 | res = res & "ID: " & .cID & vbNewLine 3494 | res = res & "Has DAT: " & .hasDatFile & vbNewLine 3495 | res = res & "Is Valid: " & .isValid & vbNewLine 3496 | End With 3497 | res = res & vbNewLine 3498 | Next i 3499 | res = res & String$(80, "-") 3500 | res = res & vbTwoNewLines 3501 | ' 3502 | ReadODProviders True 3503 | res = res & "Providers found: " & m_providers.pCount & vbTwoNewLines 3504 | For i = 1 To m_providers.pCount 3505 | With m_providers.arr(i) 3506 | res = res & "Base Mount: " & .baseMount & vbNewLine 3507 | res = res & "Is Business: " & .isBusiness & vbNewLine 3508 | res = res & "Is Main: " & .isMain & vbNewLine 3509 | res = res & "Mount Point: " & .mountPoint & vbNewLine 3510 | res = res & "Sync ID: " & .syncID & vbNewLine 3511 | res = res & "Web Path: " & .webPath & vbNewLine 3512 | #If Mac Then 3513 | res = res & "Sync Dir: " & .syncDir & vbNewLine 3514 | #End If 3515 | End With 3516 | res = res & vbNewLine 3517 | Next i 3518 | ' 3519 | Open filePath For Output As #fileNumber 3520 | Print #fileNumber, res 3521 | Close #fileNumber 3522 | ' 3523 | MsgBox "Created [" & fileName & "] diagnostics file", vbInformation 3524 | End Sub 3525 | -------------------------------------------------------------------------------- /src/UDF_FileTools.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "UDF_FileTools" 2 | '''============================================================================= 3 | ''' VBA FileTools 4 | ''' --------------------------------------------- 5 | ''' https://github.com/cristianbuse/VBA-FileTools 6 | ''' --------------------------------------------- 7 | ''' MIT License 8 | ''' 9 | ''' Copyright (c) 2012 Ion Cristian Buse 10 | ''' 11 | ''' Permission is hereby granted, free of charge, to any person obtaining a copy 12 | ''' of this software and associated documentation files (the "Software"), to 13 | ''' deal in the Software without restriction, including without limitation the 14 | ''' rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 15 | ''' sell copies of the Software, and to permit persons to whom the Software is 16 | ''' furnished to do so, subject to the following conditions: 17 | ''' 18 | ''' The above copyright notice and this permission notice shall be included in 19 | ''' all copies or substantial portions of the Software. 20 | ''' 21 | ''' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | ''' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | ''' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 24 | ''' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | ''' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | ''' FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 27 | ''' IN THE SOFTWARE. 28 | '''============================================================================= 29 | 30 | Option Explicit 31 | 32 | '******************************************************************************* 33 | ''Excel File Tools Module 34 | ''Functions in this module make it easy for the user to work with file paths 35 | '' within the Excel interface using the FileTools library 36 | ''Functions below are capable to 'spill' on newer Excel versions (Office 365) 37 | '******************************************************************************* 38 | 39 | ''Important! 40 | '******************************************************************************* 41 | ''This module is intended to be used in Microsoft Excel only! 42 | ''Call the User-Defined-Functions (UDFs) in this module from Excel Ranges only 43 | '' DO NOT call these functions from VBA! If you need any of the functions below 44 | '' directly in VBA then use their equivalent from the LibFileTools module 45 | '******************************************************************************* 46 | 47 | ''Requires: 48 | '' - LibFileTools: library module 49 | 50 | ''Exposed Excel UDFs: 51 | '' - IS_FILE 52 | '' - IS_FOLDER 53 | '' - LOCAL_PATH 54 | '' - REMOTE_PATH 55 | 56 | '******************************************************************************* 57 | 'Turn the below compiler constant to True if you are using the LibUDFs library 58 | 'https://github.com/cristianbuse/VBA-FastExcelUDFs 59 | #Const USE_LIB_FAST_UDFS = False 60 | '******************************************************************************* 61 | 62 | Public Function IS_FILE(ByRef filePaths As Variant) As Variant 63 | Application.Volatile False 64 | #If USE_LIB_FAST_UDFS Then 65 | LibUDFs.TriggerFastUDFCalculation 66 | #End If 67 | ' 68 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 69 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 70 | If VBA.TypeName(filePaths) = "Range" Then 71 | If filePaths.Areas.Count > 1 Then GoTo FailInput 72 | filePaths = filePaths.Value2 73 | End If 74 | ' 75 | On Error GoTo ErrorHandler 76 | If Not IsArray(filePaths) Then 77 | IS_FILE = LibFileTools.IsFile(CStr(filePaths)) 78 | Exit Function 79 | End If 80 | ' 81 | Dim res() As Boolean 82 | Dim i As Long 83 | Dim j As Long 84 | ' 85 | Select Case GetArrayDimsCount(filePaths) 86 | Case 1 87 | ReDim res(LBound(filePaths) To UBound(filePaths)) 88 | For i = LBound(filePaths) To UBound(filePaths) 89 | res(i) = LibFileTools.IsFile(CStr(filePaths(i))) 90 | Next i 91 | Case 2 92 | ReDim res(LBound(filePaths, 1) To UBound(filePaths, 1) _ 93 | , LBound(filePaths, 2) To UBound(filePaths, 2)) 94 | For i = LBound(filePaths, 1) To UBound(filePaths, 1) 95 | For j = LBound(filePaths, 2) To UBound(filePaths, 2) 96 | res(i, j) = LibFileTools.IsFile(CStr(filePaths(i, j))) 97 | Next j 98 | Next i 99 | Case Else 100 | GoTo FailInput 101 | End Select 102 | ' 103 | IS_FILE = res 104 | Exit Function 105 | ErrorHandler: 106 | FailInput: 107 | IS_FILE = VBA.CVErr(xlErrValue) 108 | End Function 109 | 110 | Public Function IS_FOLDER(ByRef folderPaths As Variant) As Variant 111 | Application.Volatile False 112 | #If USE_LIB_FAST_UDFS Then 113 | LibUDFs.TriggerFastUDFCalculation 114 | #End If 115 | ' 116 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 117 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 118 | If VBA.TypeName(folderPaths) = "Range" Then 119 | If folderPaths.Areas.Count > 1 Then GoTo FailInput 120 | folderPaths = folderPaths.Value2 121 | End If 122 | ' 123 | On Error GoTo ErrorHandler 124 | If Not IsArray(folderPaths) Then 125 | IS_FOLDER = LibFileTools.IsFolder(CStr(folderPaths)) 126 | Exit Function 127 | End If 128 | ' 129 | Dim res() As Boolean 130 | Dim i As Long 131 | Dim j As Long 132 | ' 133 | Select Case GetArrayDimsCount(folderPaths) 134 | Case 1 135 | ReDim res(LBound(folderPaths) To UBound(folderPaths)) 136 | For i = LBound(folderPaths) To UBound(folderPaths) 137 | res(i) = LibFileTools.IsFolder(CStr(folderPaths(i))) 138 | Next i 139 | Case 2 140 | ReDim res(LBound(folderPaths, 1) To UBound(folderPaths, 1) _ 141 | , LBound(folderPaths, 2) To UBound(folderPaths, 2)) 142 | For i = LBound(folderPaths, 1) To UBound(folderPaths, 1) 143 | For j = LBound(folderPaths, 2) To UBound(folderPaths, 2) 144 | res(i, j) = LibFileTools.IsFolder(CStr(folderPaths(i, j))) 145 | Next j 146 | Next i 147 | Case Else 148 | GoTo FailInput 149 | End Select 150 | ' 151 | IS_FOLDER = res 152 | Exit Function 153 | ErrorHandler: 154 | FailInput: 155 | IS_FOLDER = VBA.CVErr(xlErrValue) 156 | End Function 157 | 158 | Public Function LOCAL_PATH(ByRef fullPaths As Variant) As Variant 159 | Application.Volatile False 160 | #If USE_LIB_FAST_UDFS Then 161 | LibUDFs.TriggerFastUDFCalculation 162 | #End If 163 | ' 164 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 165 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 166 | If VBA.TypeName(fullPaths) = "Range" Then 167 | If fullPaths.Areas.Count > 1 Then GoTo FailInput 168 | fullPaths = fullPaths.Value2 169 | End If 170 | ' 171 | On Error GoTo ErrorHandler 172 | If Not IsArray(fullPaths) Then 173 | LOCAL_PATH = LibFileTools.GetLocalPath(CStr(fullPaths)) 174 | Exit Function 175 | End If 176 | ' 177 | Dim res() As String 178 | Dim i As Long 179 | Dim j As Long 180 | ' 181 | Select Case GetArrayDimsCount(fullPaths) 182 | Case 1 183 | ReDim res(LBound(fullPaths) To UBound(fullPaths)) 184 | For i = LBound(fullPaths) To UBound(fullPaths) 185 | res(i) = LibFileTools.GetLocalPath(CStr(fullPaths(i))) 186 | Next i 187 | Case 2 188 | ReDim res(LBound(fullPaths, 1) To UBound(fullPaths, 1) _ 189 | , LBound(fullPaths, 2) To UBound(fullPaths, 2)) 190 | For i = LBound(fullPaths, 1) To UBound(fullPaths, 1) 191 | For j = LBound(fullPaths, 2) To UBound(fullPaths, 2) 192 | res(i, j) = LibFileTools.GetLocalPath(CStr(fullPaths(i, j))) 193 | Next j 194 | Next i 195 | Case Else 196 | GoTo FailInput 197 | End Select 198 | ' 199 | LOCAL_PATH = res 200 | Exit Function 201 | ErrorHandler: 202 | FailInput: 203 | LOCAL_PATH = VBA.CVErr(xlErrValue) 204 | End Function 205 | 206 | Public Function REMOTE_PATH(ByRef fullPaths As Variant) As Variant 207 | Application.Volatile False 208 | #If USE_LIB_FAST_UDFS Then 209 | LibUDFs.TriggerFastUDFCalculation 210 | #End If 211 | ' 212 | 'Only accept 1-Area Ranges. This could alternatively be changed to ignore 213 | ' the extra Areas by arr = arr.Areas(1).Value2 instead of the 2 lines 214 | If VBA.TypeName(fullPaths) = "Range" Then 215 | If fullPaths.Areas.Count > 1 Then GoTo FailInput 216 | fullPaths = fullPaths.Value2 217 | End If 218 | ' 219 | On Error GoTo ErrorHandler 220 | If Not IsArray(fullPaths) Then 221 | REMOTE_PATH = LibFileTools.GetRemotePath(CStr(fullPaths)) 222 | Exit Function 223 | End If 224 | ' 225 | Dim res() As String 226 | Dim i As Long 227 | Dim j As Long 228 | ' 229 | Select Case GetArrayDimsCount(fullPaths) 230 | Case 1 231 | ReDim res(LBound(fullPaths) To UBound(fullPaths)) 232 | For i = LBound(fullPaths) To UBound(fullPaths) 233 | res(i) = LibFileTools.GetRemotePath(CStr(fullPaths(i))) 234 | Next i 235 | Case 2 236 | ReDim res(LBound(fullPaths, 1) To UBound(fullPaths, 1) _ 237 | , LBound(fullPaths, 2) To UBound(fullPaths, 2)) 238 | For i = LBound(fullPaths, 1) To UBound(fullPaths, 1) 239 | For j = LBound(fullPaths, 2) To UBound(fullPaths, 2) 240 | res(i, j) = LibFileTools.GetRemotePath(CStr(fullPaths(i, j))) 241 | Next j 242 | Next i 243 | Case Else 244 | GoTo FailInput 245 | End Select 246 | ' 247 | REMOTE_PATH = res 248 | Exit Function 249 | ErrorHandler: 250 | FailInput: 251 | REMOTE_PATH = VBA.CVErr(xlErrValue) 252 | End Function 253 | 254 | '******************************************************************************* 255 | 'Returns the Number of dimensions for an input array 256 | 'Returns 0 if array is uninitialized or input not an array 257 | 'Note that a zero-length array has 1 dimension! Ex. Array() bounds are (0 to -1) 258 | '******************************************************************************* 259 | Private Function GetArrayDimsCount(ByRef arr As Variant) As Long 260 | Const MAX_DIMENSION As Long = 60 'VB limit 261 | Dim dimension As Long 262 | Dim tempBound As Long 263 | ' 264 | On Error GoTo FinalDimension 265 | For dimension = 1 To MAX_DIMENSION 266 | tempBound = LBound(arr, dimension) 267 | Next dimension 268 | FinalDimension: 269 | GetArrayDimsCount = dimension - 1 270 | End Function 271 | --------------------------------------------------------------------------------