-
Notifications
You must be signed in to change notification settings - Fork 40
/
modFileAccess.bas
606 lines (504 loc) · 21 KB
/
modFileAccess.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
Attribute VB_Name = "modFileAccess"
'---------------------------------------------------------------------------------------
' Module : modFileAccess
' Author : Adam Waller
' Date : 12/4/2020
' Purpose : General functions for reading and writing files, building and verifying
' : paths, and parsing file names.
'---------------------------------------------------------------------------------------
Option Compare Database
Option Private Module
Option Explicit
Private Const ModuleName As String = "modFileAccess"
Private Declare PtrSafe Function getTempPath Lib "kernel32" Alias "GetTempPathA" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function getTempFileName Lib "kernel32" Alias "GetTempFileNameA" ( _
ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
'---------------------------------------------------------------------------------------
' Procedure : GetTempFile
' Author : Adapted by Adam Waller
' Date : 1/23/2019
' Purpose : Generate Random / Unique temporary file name. (Also creates the file)
'---------------------------------------------------------------------------------------
'
Public Function GetTempFile(Optional strPrefix As String = "VBA") As String
Dim strPath As String * 512
Dim strName As String * 576
Dim lngReturn As Long
lngReturn = getTempPath(512, strPath)
lngReturn = getTempFileName(strPath, strPrefix, 0, strName)
If lngReturn <> 0 Then GetTempFile = Left$(strName, InStr(strName, vbNullChar) - 1)
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetTempFolder
' Author : Adam Waller
' Date : 9/24/2021
' Purpose : Get a random unique folder name and create the folder.
'---------------------------------------------------------------------------------------
'
Public Function GetTempFolder(Optional strPrefix As String = "VBA") As String
Dim strPath As String
Dim strFile As String
Dim strFolder As String
' Generate a random temporary file name, and delete the temp file
strPath = GetTempFile(strPrefix)
DeleteFile strPath
' Change path to use underscore instead of period.
strFile = PathSep & FSO.GetFileName(strPath)
strFolder = Replace(strFile, ".", "_")
strPath = Replace(strPath, strFile, strFolder)
If FSO.FolderExists(strPath) Then
' Oops, this folder already exists. Try again.
GetTempFolder = GetTempFolder(strPrefix)
Else
' Create folder and return path
FSO.CreateFolder strPath
GetTempFolder = strPath
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : ReadFile
' Author : Adam Waller / Indigo
' Date : 11/4/2020
' Purpose : Read text file.
' : Read in UTF-8 encoding, removing a BOM if found at start of file.
'---------------------------------------------------------------------------------------
'
Public Function ReadFile(strPath As String, Optional strCharset As String = "utf-8") As String
Dim cData As clsConcat
Set cData = New clsConcat
If FSO.FileExists(strPath) Then
Perf.OperationStart "Read File"
With New ADODB.Stream
.Charset = strCharset
.Open
.LoadFromFile strPath
' Read chunks of text, rather than the whole thing at once for massive
' performance gains when reading large files.
' See https://docs.microsoft.com/is-is/sql/ado/reference/ado-api/readtext-method
Do While Not .EOS
cData.Add .ReadText(CHUNK_SIZE) ' 128K
Loop
.Close
End With
Perf.OperationEnd
End If
' Return text contents of file.
ReadFile = cData.GetStr
End Function
'---------------------------------------------------------------------------------------
' Procedure : WriteFile
' Author : Adam Waller
' Date : 1/23/2019
' Purpose : Save string variable to text file. (Building the folder path if needed)
' : Saves in UTF-8 encoding, adding a BOM if extended or unicode content
' : is found in the file. https://stackoverflow.com/a/53036838/4121863
'---------------------------------------------------------------------------------------
'
Public Sub WriteFile(strText As String, strPath As String, Optional strEncoding As String = "utf-8")
Perf.OperationStart "Write File"
' Write to a UTF-8 eoncoded file
With New ADODB.Stream
.Type = adTypeText
.Open
.Charset = strEncoding
.WriteText strText
' Ensure that we are ending the content with a vbcrlf
If Right(strText, 2) <> vbCrLf Then .WriteText vbCrLf
' Write to disk
VerifyPath strPath
' Watch out for possible write error
LogUnhandledErrors
On Error Resume Next
.SaveToFile strPath, adSaveCreateOverWrite
If Catch(3004) Then
' File is locked. Try again after 1 second, just in case something
' like Google Drive momentarily locked the file.
Err.Clear
Pause 1
.SaveToFile strPath, adSaveCreateOverWrite
End If
CatchAny eelError, "Error writing file: " & strPath, ModuleName & ".WriteFile"
.Close
End With
Perf.OperationEnd
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetFileBytes
' Author : Adam Waller
' Date : 7/31/2020
' Purpose : Returns a byte array of the file contents.
' : This function supports Unicode paths, unlike VBA's Open statement.
'---------------------------------------------------------------------------------------
'
Public Function GetFileBytes(strPath As String, Optional lngBytes As Long = adReadAll) As Byte()
Perf.OperationStart "Read File Bytes"
With New ADODB.Stream
.Type = adTypeBinary
.Open
.LoadFromFile strPath
GetFileBytes = .Read(lngBytes)
.Close
End With
Perf.OperationEnd
End Function
'---------------------------------------------------------------------------------------
' Procedure : WriteBinaryFile
' Author : Adam Waller
' Date : 7/9/2021
' Purpose : Writes the file bytes to a file (with Unicode path support)
'---------------------------------------------------------------------------------------
'
Public Function WriteBinaryFile(strPath As String, bteArray() As Byte)
Perf.OperationStart "Write Binary File"
With New ADODB.Stream
.Type = adTypeBinary
.Open
.Write bteArray
VerifyPath strPath
.SaveToFile strPath, adSaveCreateOverWrite
.Close
End With
Perf.OperationEnd
End Function
'---------------------------------------------------------------------------------------
' Procedure : DeleteFile
' Author : Adam Waller
' Date : 11/5/2020
' Purpose : Wrapper to delete file while monitoring performance.
'---------------------------------------------------------------------------------------
'
Public Sub DeleteFile(strFile As String, Optional blnForce As Boolean = True)
Perf.OperationStart "Delete File"
FSO.DeleteFile strFile, blnForce
Perf.OperationEnd
End Sub
'---------------------------------------------------------------------------------------
' Procedure : MkDirIfNotExist
' Author : Adam Waller
' Date : 1/25/2019
' Purpose : Create folder `Path`. Silently do nothing if it already exists.
'---------------------------------------------------------------------------------------
'
Public Sub MkDirIfNotExist(strPath As String)
If Not FSO.FolderExists(StripSlash(strPath)) Then
Perf.OperationStart "Create Folder"
FSO.CreateFolder StripSlash(strPath)
Perf.OperationEnd
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : MoveFileIfExists
' Author : Adam Waller
' Date : 9/10/2022
' Purpose : Moves a file to a specified destination folder, creating the destination
' : folder if it does not exist.
'---------------------------------------------------------------------------------------
'
Public Sub MoveFileIfExists(strFilePath As String, strToFolder As String)
Dim strNewPath As String
If FSO.FileExists(strFilePath) Then
Perf.OperationStart "Move File"
MkDirIfNotExist strToFolder
strNewPath = StripSlash(strToFolder) & PathSep & FSO.GetFileName(strFilePath)
If FSO.FileExists(strNewPath) Then DeleteFile strNewPath
FSO.MoveFile strFilePath, strNewPath
Perf.OperationEnd
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : MoveFolderIfExists
' Author : Adam Waller
' Date : 9/10/2022
' Purpose : Move a folder to a new location, replacing any existing folder.
'---------------------------------------------------------------------------------------
'
Public Sub MoveFolderIfExists(strFolderPath As String, strToParentFolder As String)
Dim strNewPath As String
If FSO.FolderExists(strFolderPath) Then
Perf.OperationStart "Move Folder"
MkDirIfNotExist strToParentFolder
strNewPath = StripSlash(strToParentFolder) & PathSep & FSO.GetFolder(strFolderPath).Name
If FSO.FolderExists(strNewPath) Then FSO.DeleteFolder strNewPath, True
FSO.MoveFolder strFolderPath, strNewPath
Perf.OperationEnd
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : clearfilesbyextension
' Author : Adam Waller
' Date : 1/25/2019
' Purpose : Erase all *.`ext` files in `Path`.
'---------------------------------------------------------------------------------------
'
Public Sub ClearFilesByExtension(ByVal strFolder As String, strExt As String)
Dim oFile As Scripting.File
Dim strFolderNoSlash As String
' While the Dir() function would be simpler, it does not support Unicode.
strFolderNoSlash = StripSlash(strFolder)
If FSO.FolderExists(strFolderNoSlash) Then
For Each oFile In FSO.GetFolder(strFolderNoSlash).Files
If StrComp(FSO.GetExtensionName(oFile.Name), strExt, vbTextCompare) = 0 Then
' Found at least one matching file. Use the wildcard delete.
DeleteFile FSO.BuildPath(strFolderNoSlash, "*." & strExt)
Exit Sub
End If
Next
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : VerifyPath
' Author : Adam Waller
' Date : 8/3/2020
' Purpose : Verifies that the folder path to a folder or file exists.
' : Use this to verify the folder path before attempting to write a file.
'---------------------------------------------------------------------------------------
'
Public Sub VerifyPath(strPath As String)
Dim strFolder As String
Dim varParts As Variant
Dim intPart As Integer
Dim strVerified As String
If strPath = vbNullString Then Exit Sub
Perf.OperationStart "Verify Path"
' Determine if the path is a file or folder
If Right$(strPath, 1) = PathSep Then
' Folder name. (Folder names can contain periods)
strFolder = Left$(strPath, Len(strPath) - 1)
Else
' File name
strFolder = FSO.GetParentFolderName(strPath)
End If
' Check if full path exists.
If Not FSO.FolderExists(strFolder) Then
' Start from the root, and build out full path, creating folders as needed.
' UNC path? change 3 "\" into 3 "@"
If strFolder Like PathSep & PathSep & "*" & PathSep & "*" Then
strFolder = Replace(strFolder, PathSep, "@", 1, 3)
End If
' Separate folders from server name
varParts = Split(strFolder, PathSep)
' Get the slashes back
varParts(0) = Replace(varParts(0), "@", PathSep, 1, 3)
' Make sure the root folder exists. If it doesn't we probably have some other issue.
If Not FSO.FolderExists(varParts(0)) Then
MsgBox2 "Path Not Found", "Could not find the path '" & varParts(0) & "' on this system.", _
"While trying to verify this path: " & strFolder, vbExclamation
Else
' Loop through folder structure, creating as needed.
strVerified = varParts(0) & PathSep
For intPart = 1 To UBound(varParts)
strVerified = FSO.BuildPath(strVerified, varParts(intPart))
MkDirIfNotExist strVerified
Next intPart
End If
End If
' End timing of operation
Perf.OperationEnd
End Sub
'---------------------------------------------------------------------------------------
' Procedure : ProgramFilesFolder
' Author : Adam Waller
' Date : 5/15/2015
' Purpose : Returns the program files folder on the OS. (32 or 64 bit)
'---------------------------------------------------------------------------------------
'
Public Function ProgramFilesFolder() As String
Dim strFolder As String
strFolder = Environ$("PROGRAMFILES")
' Should always work, but just in case!
If strFolder = vbNullString Then strFolder = "C:\Program Files (x86)"
ProgramFilesFolder = strFolder & PathSep
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetFilePathsInFolder
' Author : Adam Waller
' Date : 4/23/2020
' Purpose : Returns a collection containing the full paths of files in a folder.
' : Wildcards are supported.
'---------------------------------------------------------------------------------------
'
Public Function GetFilePathsInFolder(strFolder As String, Optional strFilePattern As String = "*.*") As Dictionary
Dim oFile As Scripting.File
Dim strBaseFolder As String
strBaseFolder = StripSlash(strFolder)
Set GetFilePathsInFolder = New Dictionary
Perf.OperationStart "Get File List"
If FSO.FolderExists(strBaseFolder) Then
For Each oFile In FSO.GetFolder(strBaseFolder).Files
' Add files that match the pattern.
If oFile.Name Like strFilePattern Then GetFilePathsInFolder.Add oFile.Path, vbNullString
Next oFile
End If
Perf.OperationEnd
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetSubfolderPaths
' Author : Adam Waller
' Date : 7/30/2020
' Purpose : Return a collection of subfolders inside a folder.
'---------------------------------------------------------------------------------------
'
Public Function GetSubfolderPaths(strPath As String) As Dictionary
Dim strBase As String
Dim oFolder As Scripting.Folder
Set GetSubfolderPaths = New Dictionary
strBase = StripSlash(strPath)
If FSO.FolderExists(strBase) Then
For Each oFolder In FSO.GetFolder(strBase).SubFolders
GetSubfolderPaths.Add oFolder.Path, vbNullString
Next oFolder
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : ReadJsonFile
' Author : Adam Waller
' Date : 5/5/2020
' Purpose : Reads a Json file into a dictionary object
'---------------------------------------------------------------------------------------
'
Public Function ReadJsonFile(strPath As String) As Dictionary
Dim strText As String
strText = ReadFile(strPath)
' If it looks like json content, then parse into a dictionary object.
If Left$(strText, 1) = "{" Then
Set ReadJsonFile = ParseJson(strText)
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetRelativePath
' Author : Adam Waller
' Date : 5/11/2020
' Purpose : Returns a path relative to current database.
' : If a relative path is not possible, it returns the original full path.
'---------------------------------------------------------------------------------------
'
Public Function GetRelativePath(strPath As String) As String
Dim strFolder As String
Dim strUncPath As String
Dim strUncTest As String
Dim strRelative As String
' Check for matching parent folder as relative to the project path.
strFolder = GetUncPath(CurrentProject.Path) & PathSep
' Default to original path if no relative path could be resolved.
strRelative = strPath
' Compare strPath to the current project path
If InStr(1, strPath, strFolder, vbTextCompare) = 1 Then
' In export folder or subfolder. Simple replacement
strRelative = "rel:" & Mid$(strPath, Len(strFolder) + 1)
Else
' Make sure we have a path, not just a file name.
If InStr(1, strRelative, PathSep) > 0 Then
' Check UNC path for network drives
strUncPath = GetUncPath(strPath)
If StrComp(strUncPath, strPath, vbTextCompare) <> 0 Then
' We are dealing with a network drive
strUncTest = GetRelativePath(strUncPath)
If StrComp(strUncPath, strUncTest, vbTextCompare) <> 0 Then
' Resolved to relative UNC path
strRelative = strUncTest
End If
End If
End If
End If
' Return relative (or original) path
GetRelativePath = strRelative
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetPathFromRelative
' Author : Adam Waller
' Date : 5/11/2020
' Purpose : Expands a relative path out to the full path.
'---------------------------------------------------------------------------------------
'
Public Function GetPathFromRelative(strPath As String) As String
If IsRelativePath(strPath) Then
GetPathFromRelative = FSO.BuildPath(CurrentProject.Path, Mid$(strPath, 5))
Else
' No relative path used.
GetPathFromRelative = strPath
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : IsRelativePath
' Author : Adam Waller
' Date : 10/29/2021
' Purpose : Returns true if the specified path is stored as relative.
'---------------------------------------------------------------------------------------
'
Public Function IsRelativePath(strPath As String) As Boolean
IsRelativePath = (Left$(strPath, 4) = "rel:")
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetUncPath
' Author : Adam Waller
' Date : 7/14/2020
' Purpose : Returns the UNC path for a network location (if applicable)
'---------------------------------------------------------------------------------------
'
Public Function GetUncPath(strPath As String)
Dim strDrive As String
Dim strUNC As String
strUNC = strPath
strDrive = FSO.GetDriveName(strPath)
If strDrive <> vbNullString Then
With FSO.GetDrive(strDrive)
If .DriveType = Remote Then
strUNC = Replace(strPath, strDrive, .ShareName, , 1, vbTextCompare)
End If
End With
End If
GetUncPath = strUNC
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetLastModifiedDate
' Author : Adam Waller
' Date : 7/30/2020
' Purpose : Get the last modified date on a folder or file with Unicode support.
'---------------------------------------------------------------------------------------
'
Public Function GetLastModifiedDate(strPath As String) As Date
Dim oFile As Scripting.File
Dim oFolder As Scripting.Folder
Perf.OperationStart "Get Modified Date"
If FSO.FileExists(strPath) Then
Set oFile = FSO.GetFile(strPath)
GetLastModifiedDate = oFile.DateLastModified
ElseIf FSO.FolderExists(strPath) Then
Set oFolder = FSO.GetFolder(strPath)
GetLastModifiedDate = oFolder.DateLastModified
End If
Perf.OperationEnd
End Function
'---------------------------------------------------------------------------------------
' Procedure : StripSlash
' Author : Adam Waller
' Date : 1/25/2019
' Purpose : Strip the trailing slash (or other path separator)
'---------------------------------------------------------------------------------------
'
Public Function StripSlash(strText As String) As String
If Right$(strText, 1) = PathSep Then
StripSlash = Left$(strText, Len(strText) - 1)
Else
StripSlash = strText
End If
End Function
'---------------------------------------------------------------------------------------
' Procedure : AddSlash
' Author : Adam Waller
' Date : 7/28/2023
' Purpose : Ensure that the string or path ends with a slash (or path separator)
'---------------------------------------------------------------------------------------
'
Public Function AddSlash(strText As String) As String
If Right$(strText, 1) = PathSep Then
AddSlash = strText
Else
AddSlash = strText & PathSep
End If
End Function