From 56eb52738c9162a2937a0353a53a4a17ebd5e443 Mon Sep 17 00:00:00 2001
From: "Jeremy D. Gerdes" <jeremy.gerdes@navy.mil>
Date: Thu, 26 Jan 2017 09:16:20 -0500
Subject: [PATCH 1/6] File and Folder actions
build directory tree, get relative path accepting '..\'as parent folder
---
VB_FileFolder.bas | 107 ++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 107 insertions(+)
create mode 100644 VB_FileFolder.bas
diff --git a/VB_FileFolder.bas b/VB_FileFolder.bas
new file mode 100644
index 0000000..b43d990
--- /dev/null
+++ b/VB_FileFolder.bas
@@ -0,0 +1,107 @@
+Attribute VB_Name = "VB_FileFolder"
+Option Explicit
+'Authored 2015-2017 by Jeremy Dean Gerdes <jeremy.gerdes@navy.mil>
+ 'Public Domain in the United States of America,
+ 'any international rights are relinquished under CC0 1.0 <https://creativecommons.org/publicdomain/zero/1.0/legalcode>
+ 'http://www.copyright.gov/title17/
+ 'In accrordance with 17 U.S.C. � 105 This work is 'noncopyright' or in the 'public domain'
+ 'Subject matter of copyright: United States Government works
+ 'protection under this title is not available for
+ 'any work of the United States Government, but the United States
+ 'Government is not precluded from receiving and holding copyrights
+ 'transferred to it by assignment, bequest, or otherwise.
+ 'as defined by 17 U.S.C � 101
+ '...
+ 'A �work of the United States Government� is a work prepared by an
+ 'officer or employee of the United States Government as part of that
+ 'person�s official duties.
+ '...
+Public Function BuildDir(strPath) As Boolean
+ On Error Resume Next
+ Dim fso As Object ' As Scripting.FileSystemObject
+ Dim arryPaths As Variant
+ Dim strBuiltPath As String, intDir As Integer, fRestore As Boolean: fRestore = False
+ If Left(strPath, 2) = "\\" Then
+ strPath = Right(strPath, Len(strPath) - 2)
+ fRestore = True
+ End If
+ Set fso = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
+ arryPaths = Split(strPath, "\")
+ 'Restore Server file path
+ If fRestore Then
+ arryPaths(0) = "\\" & arryPaths(0)
+ End If
+ For intDir = 0 To UBound(arryPaths)
+ strBuiltPath = strBuiltPath & arryPaths(intDir)
+ If Not fso.FolderExists(strBuiltPath) Then
+ fso.CreateFolder strBuiltPath
+ End If
+ strBuiltPath = strBuiltPath & "\"
+ Next
+ BuildDir = (Err.Number = 0) 'True if no errors
+End Function
+
+Public Function GetRelativePathViaParentAlternateRoot(ByVal strRootPath As String, ByVal strDestination As String, Optional ByRef intParentCount As Integer)
+ If Left(strDestination, 3) = "..\" Then
+ intParentCount = intParentCount + 1
+ strRootPath = Left(strRootPath, InStrRev(strRootPath, "\") - 1)
+ strDestination = Right(strDestination, Len(strDestination) - 3)
+ GetRelativePathViaParentAlternateRoot = GetRelativePathViaParentAlternateRoot(strRootPath, strDestination, intParentCount)
+ ElseIf Left(strDestination, 1) = "\" And Not (Left(strDestination, 2) = "\\") Then
+ strDestination = Right(strDestination, Len(strDestination) - 1)
+ ElseIf Right(strDestination, 1) = "\" Then
+ strDestination = Left(strDestination, Len(strDestination) - 1)
+ End If
+ If intParentCount <> -1 Then
+ GetRelativePathViaParentAlternateRoot = StripTrailingBackSlash(strRootPath) & "\" & strDestination
+ End If
+ intParentCount = -1
+End Function
+
+Public Function GetRelativePathViaParent(Optional ByVal strPath)
+'Usage for up 2 dirs is GetRelativePathViaParent("..\..\Destination")
+Dim strCurrentPath As String, strVal As String
+Dim oThisApplication As Object: Set oThisApplication = Application
+Dim fIsServerPath As Boolean: fIsServerPath = False
+Dim aryCurrentFolder As Variant, aryParentPath As Variant
+ Select Case True
+ Case InStrRev(oThisApplication.Name, "Excel") > 0
+ strCurrentPath = oThisApplication.ThisWorkbook.Path
+ Case InStrRev(oThisApplication.Name, "Access") > 0
+ strCurrentPath = oThisApplication.CurrentProject.Path
+ End Select
+ If Left(strCurrentPath, 2) = "\\" Then
+ strCurrentPath = Right(strCurrentPath, Len(strCurrentPath) - 2)
+ fIsServerPath = True
+ End If
+ aryCurrentFolder = Split(strCurrentPath, "\")
+ If IsMissing(strPath) Then
+ strPath = vbNullString
+ End If
+ aryParentPath = Split(strPath, "..\")
+ If fIsServerPath Then
+ aryCurrentFolder(0) = "\\" & aryCurrentFolder(0)
+ End If
+ Dim intDir As Integer, intParentCount As Integer
+ If UBound(aryParentPath) = -1 Then
+ intParentCount = 0
+ Else
+ intParentCount = UBound(aryParentPath)
+ End If
+ For intDir = 0 To UBound(aryCurrentFolder) - intParentCount
+ strVal = strVal & aryCurrentFolder(intDir) & "\"
+ Next
+ strVal = StripTrailingBackSlash(strVal)
+ If IsArrayAllocated(aryParentPath) Then
+ strVal = strVal & "\" & aryParentPath(UBound(aryParentPath))
+ End If
+ GetRelativePathViaParent = strVal
+End Function
+
+Public Function StripTrailingBackSlash(ByRef strPath As String)
+ If Right(strPath, 1) = "\" Then
+ StripTrailingBackSlash = Left(strPath, Len(strPath) - 1)
+ Else
+ StripTrailingBackSlash = strPath
+ End If
+End Function
From 19c9da3a29a4187ebe9222b33b0a4bc49a69c6dd Mon Sep 17 00:00:00 2001
From: "Jeremy D. Gerdes" <jeremy.gerdes@navy.mil>
Date: Thu, 26 Jan 2017 09:17:20 -0500
Subject: [PATCH 2/6] Lisense clarification
---
VB_FileFolder.bas | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/VB_FileFolder.bas b/VB_FileFolder.bas
index b43d990..98cc874 100644
--- a/VB_FileFolder.bas
+++ b/VB_FileFolder.bas
@@ -2,7 +2,7 @@ Attribute VB_Name = "VB_FileFolder"
Option Explicit
'Authored 2015-2017 by Jeremy Dean Gerdes <jeremy.gerdes@navy.mil>
'Public Domain in the United States of America,
- 'any international rights are relinquished under CC0 1.0 <https://creativecommons.org/publicdomain/zero/1.0/legalcode>
+ 'any international rights are waived through the CC0 1.0 Universal public domain dedication <https://creativecommons.org/publicdomain/zero/1.0/legalcode>
'http://www.copyright.gov/title17/
'In accrordance with 17 U.S.C. � 105 This work is 'noncopyright' or in the 'public domain'
'Subject matter of copyright: United States Government works
From d8ec7717d410e9afa2532d08097103add84a8ff3 Mon Sep 17 00:00:00 2001
From: "Jeremy D. Gerdes" <jeremy.gerdes@navy.mil>
Date: Thu, 26 Jan 2017 09:18:46 -0500
Subject: [PATCH 3/6] Renamed VBALib_FolderUtilis.bas
---
VB_FileFolder.bas => VBALib_FolderUtilis.bas | 0
1 file changed, 0 insertions(+), 0 deletions(-)
rename VB_FileFolder.bas => VBALib_FolderUtilis.bas (100%)
diff --git a/VB_FileFolder.bas b/VBALib_FolderUtilis.bas
similarity index 100%
rename from VB_FileFolder.bas
rename to VBALib_FolderUtilis.bas
From adc9960ecc9aa5ecda10dc6a95b7208deb25fa78 Mon Sep 17 00:00:00 2001
From: Hans Voll <33080008+hvoll44@users.noreply.github.com>
Date: Fri, 1 May 2020 20:07:37 -0400
Subject: [PATCH 4/6] Update VBALib_ArrayUtils.bas
Fixed external library call to be 64 bit compatible
---
VBALib_ArrayUtils.bas | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/VBALib_ArrayUtils.bas b/VBALib_ArrayUtils.bas
index 958323a..c2e1019 100644
--- a/VBALib_ArrayUtils.bas
+++ b/VBALib_ArrayUtils.bas
@@ -5,8 +5,11 @@ Attribute VB_Name = "VBALib_ArrayUtils"
Option Explicit
-Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
- (dest As Any, source As Any, ByVal bytes As Long)
+#If VBA7 Then
+ Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long)
+#Else
+ Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long)
+#End If
Private Const NORMALIZE_LBOUND = 1
From ea2daeca7f7e116db87915f87876afc7892af23a Mon Sep 17 00:00:00 2001
From: "Jeremy D. Gerdes" <seakintruth@gmail.com>
Date: Fri, 1 May 2020 22:33:18 -0400
Subject: [PATCH 5/6] Update VBALib_VERSION.bas
---
VBALib_VERSION.bas | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/VBALib_VERSION.bas b/VBALib_VERSION.bas
index 99c9125..91117aa 100644
--- a/VBALib_VERSION.bas
+++ b/VBALib_VERSION.bas
@@ -1,4 +1,4 @@
Attribute VB_Name = "VBALib_VERSION"
-' Common VBA Library, version 2014-06-16.1
+' Common VBA Library, version 2020-05-01.1
' The other modules in this workbook whose names start with "VBALib_" provide
' commonly-used functions and types that are lacking in the VBA language.
From 99a8702cd54136968d259bb97cc55b72e88d6e85 Mon Sep 17 00:00:00 2001
From: Hans Voll <33080008+hvoll44@users.noreply.github.com>
Date: Sat, 23 May 2020 20:05:14 -0400
Subject: [PATCH 6/6] Create ListTableAndFieldProperties
Module to list all properties for all fields in an access database.
---
ListTableAndFieldProperties | 375 ++++++++++++++++++++++++++++++++++++
1 file changed, 375 insertions(+)
create mode 100644 ListTableAndFieldProperties
diff --git a/ListTableAndFieldProperties b/ListTableAndFieldProperties
new file mode 100644
index 0000000..7890f05
--- /dev/null
+++ b/ListTableAndFieldProperties
@@ -0,0 +1,375 @@
+Option Compare Database
+Option Explicit
+
+Public Sub ListAllTablesProperties(Optional fWriteToFile As Boolean = True, Optional fOpenFile As Boolean = True)
+On Error GoTo HandleError
+ Dim db As Database
+ Dim tdf As TableDef
+ Dim x As Double
+ Set db = CurrentDb
+
+ 'text file header
+ Dim strLine As String
+ strLine = _
+ "Table Name,Table Validation Rule,Table Validation Text," & _
+ "Table Attributes,Table Date Created,Table Indexes Count, Table Indexes, " & _
+ "Table Record Count,Table Properties Count,Table Properties," & _
+ "FieldName,Field Allow Zero Length, Field Attributes, Field Default Value " & _
+ "Field Required,Field Size, Field Type, Field Validation Rule, Field Validation Text, Field Count, Field Properties" & _
+ "Field Description,Field DataType Name, Field DataType,Field DataSize"
+
+ 'Write text file body
+ For Each tdf In db.TableDefs
+ If Left(tdf.Name, 4) <> "MSys" Then ' Don't enumerate the system tables
+ Dim fld As DAO.Field
+ Dim strTbfPrefix As String
+ strTbfPrefix = HandleCsvColumn(tdf.Name) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.ValidationRule) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.ValidationText) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.Attributes) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.DateCreated) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.Indexes.Count) & ","
+ If tdf.Indexes.Count = 0 Then
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(vbNullString) & ","
+ Else
+ Dim strIndexValue As String
+ strIndexValue = "|"
+ Dim varIndex As DAO.Index
+ For Each varIndex In tdf.Indexes
+ strIndexValue = strIndexValue & "Name=" & varIndex.Name & ";"
+ strIndexValue = strIndexValue & "Clustered=" & varIndex.Clustered & ";"
+ strIndexValue = strIndexValue & "DistinctCount=" & varIndex.DistinctCount & ";"
+ strIndexValue = strIndexValue & "Field Count=" & varIndex.Fields.Count & ";"
+ strIndexValue = strIndexValue & "Foreign=" & varIndex.Foreign & ";"
+ strIndexValue = strIndexValue & "IgnoreNulls=" & varIndex.IgnoreNulls & ";"
+ strIndexValue = strIndexValue & "Primary=" & varIndex.Primary & ";"
+ strIndexValue = strIndexValue & "Properties Count=" & varIndex.Properties.Count & ";"
+ strIndexValue = strIndexValue & "Required=" & varIndex.Required & ";"
+ strIndexValue = strIndexValue & "Unique=" & varIndex.Unique & ";"
+ strIndexValue = strIndexValue & "|"
+ Next
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(strIndexValue) & ","
+ End If
+
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.RecordCount) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(tdf.Properties.Count) & ","
+ strTbfPrefix = strTbfPrefix & HandleCsvColumn(GetPropertyValue(tdf.Properties))
+ For Each fld In tdf.Fields
+ Dim strFldPrefix As String
+ strFldPrefix = HandleCsvColumn(fld.Name) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.AllowZeroLength) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.Attributes) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.DefaultValue) & ","
+' strFldPrefix = strFldPrefix & HandleCsvColumn(fld.FieldSize) & ","
+' strFldPrefix = strFldPrefix & HandleCsvColumn(fld.OriginalValue) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.Required) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.Size) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.Type) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.ValidationRule) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.ValidationText) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(fld.Properties.Count) & ","
+ strFldPrefix = strFldPrefix & HandleCsvColumn(GetPropertyValue(fld.Properties))
+ strLine = strLine & vbCrLf & strTbfPrefix & "," & strFldPrefix
+ Debug.Print strTbfPrefix & "," & strFldPrefix
+ Next fld
+ End If
+ Next tdf
+ 'Create text file
+ If fWriteToFile Then
+ Dim strFilename As String
+ strFilename = RemoveFilenameExtention(CurrentProject.Name) & "_ListAllTableProperties.csv"
+ SaveTextToFile strLine, strFilename, fOpenNewFile:=fOpenFile
+ End If
+ExitSub:
+Exit Sub
+HandleError:
+ Select Case Err.Number
+ Case 3270
+ strLine = strLine & _
+ HandleCsvColumn("[Err:" & Err.Number & ":" & Err.Description & "]") & ","
+ Resume Next
+ Case Else
+ Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
+ Resume
+ 'GoTo ExitSub
+ End Select
+End Sub
+
+'Finds all tables, field names, and field descriptions, and writes output to a text file
+Public Sub ListAllTableFieldDescTypeSize(Optional fWriteToFile As Boolean = True, Optional fOpenFile As Boolean = True)
+On Error GoTo HandleError
+ Dim db As Database
+ Dim tdf As TableDef
+ Dim x As Double
+ Set db = CurrentDb
+
+ 'text file header
+ Dim strDescription As String
+ strDescription = "Table,Field,Description,DataType Name,DataType,DataSize"
+
+ Debug.Print (strDescription)
+
+ 'Write text file body
+ For Each tdf In db.TableDefs
+ If Left(tdf.Name, 4) <> "MSys" Then ' Don't enumerate the system tables
+ For x = 0 To tdf.Fields.Count - 1
+ Dim strDataType As String
+ strDataType = GetPropertyValue(tdf.Fields(x).Properties("Type"))
+ 'Ignore errors in case no description exists TODO: imporve error handler or find a way to test if "Description" property exists w/o throwing an error
+ strDescription = strDescription & vbCrLf
+ strDescription = strDescription & HandleCsvColumn(tdf.Name) & ","
+ strDescription = strDescription & HandleCsvColumn(tdf.Fields(x).Name) & ","
+ strDescription = strDescription & HandleCsvColumn(GetPropertyValue(tdf.Fields(x).Properties("Description"))) & ","
+ strDescription = strDescription & HandleCsvColumn(GetJetDataTypeEnumName(CLng(strDataType))) & ","
+ strDescription = strDescription & HandleCsvColumn((strDataType)) & ","
+ strDescription = strDescription & HandleCsvColumn(GetPropertyValue(tdf.Fields(x).Properties("Size")))
+ Next x
+ End If
+ Next tdf
+ Debug.Print strDescription
+ 'Create text file
+ If fWriteToFile Then
+ Dim strFilename As String
+ strFilename = RemoveFilenameExtention(CurrentProject.Name) & "_FieldDescTypesSizes.csv"
+ SaveTextToFile strDescription, strFilename, fOpenNewFile:=fOpenFile
+ End If
+ExitSub:
+Exit Sub
+HandleError:
+ Select Case Err.Number
+ Case 3270
+ strDescription = strDescription & _
+ HandleCsvColumn("[Err:" & Err.Number & ":" & Err.Description & "]") & ","
+ Resume Next
+ Case Else
+ Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
+ Resume
+ 'GoTo ExitSub
+ End Select
+End Sub
+
+Private Function GetPropertyValue(prp As Variant, Optional intChildDepth As Integer = 0) As String
+On Error GoTo HandleError
+ Dim strValue As String
+ strValue = vbNullString
+ Dim prpChild As Property
+ Select Case TypeName(prp)
+ Case "Property"
+ strValue = prp.Name & "="
+ On Error Resume Next
+ strValue = strValue & prp.Value
+ On Error GoTo HandleError
+ Case "Properties"
+ Dim intProperty As Integer
+ For intProperty = 1 To prp.Count
+ strValue = strValue & prp(intProperty).Name & "="
+ On Error Resume Next
+ strValue = strValue & prp(intProperty).Value
+ On Error GoTo HandleError
+ strValue = strValue & ";"
+ 'strValue = intChildDepth & ":" & strValue & ";" & GetPropertyValue(prp(intProperty), intChildDepth + 1)
+ Next intProperty
+ Case Else
+ strValue = prp.Value
+ End Select
+ GetPropertyValue = strValue
+ExitSub:
+Exit Function
+HandleError:
+ Select Case Err.Number
+ Case 3270, 438
+ strValue = Err.Description
+ Resume Next
+ Case Else
+ Debug.Print "Err:" & Err.Number & ":" & Err.Description
+ strValue = Err.Description
+ Resume Next
+ End Select
+End Function
+
+Private Function HandleCsvColumn(ByVal strText As String)
+ strText = IIf(Left(strText, 1) = "=", "'" & strText, strText)
+ If Len(strText) > 0 Then
+ HandleCsvColumn = """" & Replace(strText, """", """""") & """"
+ End If
+End Function
+
+Public Function RemoveFilenameExtention(strFilename)
+ RemoveFilenameExtention = Left(strFilename, InStrRev(strFilename, ".", , vbBinaryCompare) - 1)
+End Function
+
+Public Function GetParentPath(strFilename)
+ GetParentPath = Left(strFilename, InStrRev(strFilename, "\", , vbBinaryCompare) - 1)
+End Function
+
+Public Function FileExists(ByVal strPath As String) As Boolean
+Dim FSO As Object
+ ' Note*: We used to use the vba.Dir function but using that function
+ ' will lock the folder and prevent it from being deleted.
+ Set FSO = CreateObject("Scripting.FileSystemObject")
+ FileExists = FSO.FileExists(strPath)
+ ' Clean up
+ Set FSO = Nothing
+End Function
+
+Public Function FolderExists(ByVal strPath As String) As Boolean
+Dim FSO As Object
+ ' Note*: We used to use the vba.Dir function but using that function
+ ' will lock the folder and prevent it from being deleted.
+ Set FSO = CreateObject("Scripting.FileSystemObject")
+ FolderExists = FSO.FolderExists(strPath)
+ ' Clean up
+ Set FSO = Nothing
+End Function
+
+Public Sub SaveTextToFile( _
+ strTextToPass As String, _
+ strFilename As String, _
+ Optional strPath As String = vbNullString, _
+ Optional fOpenNewFile As Boolean = False _
+)
+ If strPath = vbNullString Then
+ strPath = CurrentProject.Path
+ Else
+ BuildDir strPath
+ End If
+ strTextToPass = Trim(strTextToPass)
+ 'save text to file
+ Dim strFullPath As String
+ strFullPath = strPath & "\" & RemoveForbiddenFilenameCharacters(strFilename)
+ Dim fCancel As Boolean
+ If FileExists(strFullPath) Then
+ If IsFileOpenLocked(strFullPath) Then
+ If MsgBox("File appears to be open, click OK after closing the file:" & vbCrLf & strFullPath & _
+ vbCrLf & vbTab & "Cancel will stop attempts to write to the file", vbCritical + vbOKCancel, RemoveFilenameExtention(CurrentProject.Name)) = vbOK _
+ Then
+ Debug.Print "User attests file is closed"
+ Else
+ Debug.Print "User canceled writing to file"
+ fCancel = True
+ End If
+ End If
+ End If
+ If Not fCancel Then
+ 'VBS Method
+ Dim FSO As Object
+ Set FSO = CreateObject("Scripting.FileSystemObject")
+ Dim oFile As Object
+ Set oFile = FSO.CreateTextFile(strFullPath, True)
+ oFile.WriteLine strTextToPass
+
+ 'VBA method
+ 'Open strFullPath For Output As #1
+ 'Write #1, strTextToPass
+ 'Close #1
+ oFile.Close
+
+ If fOpenNewFile Then
+ 'Open file
+ 'Shell "Notepad.exe " & CurrentProject.Path & "\" & strFileName, vbNormalFocus
+ OpenFileWithExplorer strFullPath
+ End If
+ 'cleanup
+ Set FSO = Nothing
+ Set oFile = Nothing
+ End If
+End Sub
+
+Public Function GetJetDataTypeEnumName(intEnum As Long)
+ Select Case intEnum
+ Case 101
+ GetJetDataTypeEnumName = "dbAttachment"
+ Case 16
+ GetJetDataTypeEnumName = "dbBigInt"
+ Case 9
+ GetJetDataTypeEnumName = "dbBinary"
+ Case 1
+ GetJetDataTypeEnumName = "dbBoolean"
+ Case 2
+ GetJetDataTypeEnumName = "dbByte"
+ Case 4
+ GetJetDataTypeEnumName = "dbLong"
+ Case 10
+ GetJetDataTypeEnumName = "bdText"
+ Case 7
+ GetJetDataTypeEnumName = "dbDouble"
+ Case 12
+ GetJetDataTypeEnumName = "dbMemo"
+ Case 8
+ GetJetDataTypeEnumName = "dbDate"
+ Case 6
+ GetJetDataTypeEnumName = "dbSingle"
+
+ End Select
+End Function
+
+Public Function BuildDir(strPath) As Boolean
+ On Error Resume Next
+ Dim FSO As Object ' As Scripting.FileSystemObject
+ Set FSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
+ If Not FSO.FolderExists(strPath) Then
+ Err.Clear
+ Dim arryPaths As Variant
+ Dim strBuiltPath As String, intDir As Integer, fRestore As Boolean: fRestore = False
+ If Left(strPath, 2) = "\\" Then
+ strPath = Right(strPath, Len(strPath) - 2)
+ fRestore = True
+ End If
+ arryPaths = Split(strPath, "\")
+ 'Restore Server file path
+ If fRestore Then
+ arryPaths(0) = "\\" & arryPaths(0)
+ End If
+ For intDir = 0 To UBound(arryPaths)
+ strBuiltPath = strBuiltPath & arryPaths(intDir)
+ If Not FSO.FolderExists(strBuiltPath) Then
+ FSO.CreateFolder strBuiltPath
+ End If
+ strBuiltPath = strBuiltPath & "\"
+ Next
+ End If
+ BuildDir = (Err.Number = 0) 'True if no errors
+ Set FSO = Nothing
+End Function
+
+Public Function RemoveForbiddenFilenameCharacters(strFilename As String) As String
+'https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247(v=vs.85).aspx
+'< (less than)
+'> (greater than)
+': (colon)
+'" (double quote)
+'/ (forward slash)
+'\ (backslash)
+'| (vertical bar or pipe)
+'? (question mark)
+'* (asterisk)
+Dim strForbidden As Variant
+ For Each strForbidden In Array("/", "\", "|", ":", "*", "?", "<", ">", """")
+ strFilename = Replace(strFilename, strForbidden, "_")
+ Next
+ RemoveForbiddenFilenameCharacters = strFilename
+End Function
+
+Public Sub OpenFileWithExplorer(ByRef strFilePath As String)
+ Dim wshShell
+ Set wshShell = CreateObject("WScript.Shell")
+ wshShell.Exec ("Explorer.exe " & strFilePath)
+ Set wshShell = Nothing
+End Sub
+
+Function IsFileOpenLocked(FileName As String) As Boolean
+ Dim ff As Long, ErrNo As Long
+
+ On Error Resume Next
+ ff = FreeFile()
+ Open FileName For Input Lock Read As #ff
+ Close ff
+ ErrNo = Err
+ On Error GoTo 0
+
+ Select Case ErrNo
+ Case 0: IsFileOpenLocked = False
+ Case 70: IsFileOpenLocked = True
+ Case Else: Error ErrNo
+ End Select
+End Function