Attribute VB_Name = "File"
Option Explicit
Option Private Module

'_______________________________________________________________________________________
'
' For OpenFile function
'_______________________________________________________________________________________
Private Const OFS_MAXPATHNAME   As Long = 128 'maximum length of whole Filename
Private Const OF_EXIST          As Long = &H4000

Private Type OFSTRUCT
    cBytes      As Byte
    fFixedDisk  As Byte
    nErrCode    As Integer
    Reserved1   As Integer
    Reserved2   As Integer
    szPathName(OFS_MAXPATHNAME) As Byte
End Type


'_______________________________________________________________________________________
'
' For CreateFile function
'_______________________________________________________________________________________

'CreateFile dwDesiredAccess
Private Const GENERIC_READ  As Long = &H80000000     'read only
Private Const GENERIC_WRITE As Long = &H40000000    'write only

'CreateFile dwShareMode
Private Const FILE_SHARE_READ   As Long = &H1
Private Const FILE_SHARE_WRITE  As Long = &H2

'CreateFile dwCreationDisposition
Private Const CREATE_NEW        As Long = 1 'create if not exists
Private Const CREATE_ALWAYS     As Long = 2 'create and override
Private Const OPEN_ALWAYS       As Long = 4 'open and create if not exists
Private Const OPEN_EXISTING     As Long = 3 'open existing File
Private Const TRUNCATE_EXISTING As Long = 5 'open existing and delete content

'CreateFile dwFlagsAndAttributes
Private Const FILE_ATTRIBUTE_ARCHIVE    As Long = &H20  'archived
Private Const FILE_ATTRIBUTE_HIDDEN     As Long = &H2   'hidden
Private Const FILE_ATTRIBUTE_NORMAL     As Long = &H80  'normal
Private Const FILE_ATTRIBUTE_READONLY   As Long = &H1   'read only File
Private Const FILE_ATTRIBUTE_SYSTEM     As Long = &H4   'SystemFile
Private Const FILE_FLAG_DELETE_ON_CLOSE As Long = &H4000000     'delete after closing
Private Const FILE_FLAG_NO_BUFFERING    As Long = &H20000000    'using no buffer/cache
Private Const FILE_FLAG_OVERLAPPED      As Long = &H40000000    'allow parallel read write (not on Win95, 98, CE)
Private Const FILE_FLAG_POSIX_SEMANTICS As Long = &H1000000     'Case-Sensitive Filename
Private Const FILE_FLAG_RANDOM_ACCESS   As Long = &H10000000    'buffer for random access
Private Const FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000     'buffer for sequential access
Private Const FILE_FLAG_WRITE_THROUGH   As Long = &H80000000    'no physical cache -> direct write



#If VBA7 Then
    Private Declare PtrSafe Function GetOpenFileName _
    Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
        ByRef pOpenFilename As OPENFILENAME) _
    As Long

    Private Type OPENFILENAME
        lStructSize         As Long
        hwndOwner           As LongPtr
        hInstance           As LongPtr
        lpstrFilter         As String
        lpstrCustomFilter   As String
        nMaxCustFilter      As Long
        nFilterIndex        As Long
        lpstrFile           As String
        nMaxFile            As Long
        lpstrFileTitle      As String
        nMaxFileTitle       As Long
        lpstrInitialDir     As String
        lpstrTitle          As String
        flags               As Long
        nFileOffset         As Integer
        nFileExtension      As Integer
        lpstrDefExt         As String
        lCustData           As LongPtr
        lpfnHook            As LongPtr
        lpTemplateName      As String
    End Type

#Else

    Public Declare Function GetOpenFileName _
    Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
        ByRef pOpenFilename As OPENFILENAME) _
    As Long

    Private Type OPENFILENAME
        lStructSize         As Long
        hwndOwner           As Long
        hInstance           As Long
        lpstrFilter         As String
        lpstrCustomFilter   As String
        nMaxCustFilter      As Long
        nFilterIndex        As Long
        lpstrFile           As String
        nMaxFile            As Long
        lpstrFileTitle      As String
        nMaxFileTitle       As Long
        lpstrInitialDir     As String
        lpstrTitle          As String
        flags               As Long
        nFileOffset         As Integer
        nFileExtension      As Integer
        lpstrDefExt         As String
        lCustData           As Long
        lpfnHook            As Long
        lpTemplateName      As String
    End Type

#End If

#If Win64 Then
    Private Declare PtrSafe Function CloseHandle _
    Lib "kernel32.dll" ( _
        ByVal hObject As Long) _
    As Long
    
    Private Declare PtrSafe Function openFile _
    Lib "kernel32.dll" Alias _
        "OpenFile" (ByVal lpFileName As _
        String, ByRef lpReOpenBuffer As _
        OFSTRUCT, ByVal wStyle As _
    Long) As Long

    Private Declare PtrSafe Function GetFileSecurity _
    Lib "advapi32.dll" Alias "GetFileSecurityA" ( _
        ByVal lpFileName As String, _
        ByVal RequestedInformation As Long, _
        ByRef pSecurityDescriptor As Byte, _
        ByVal nLenght As Long, _
        ByRef lpnLenghtNeeded As Long) _
    As Long
    
#Else
    Private Declare Function CloseHandle _
    Lib "kernel32.dll" ( _
        ByVal hObject As Long) _
    As Long

    Private Declare Function openFile _
    Lib "kernel32.dll" Alias _
        "OpenFile" (ByVal lpFileName As _
        String, ByRef lpReOpenBuff As _
        OFSTRUCT, ByVal wStyle As _
    Long) As Long

    Private Declare Function GetFileSecurity _
    Lib "advapi32.dll" Alias "GetFileSecurityA" ( _
        ByVal lpFileName As String, _
        ByVal RequestedInformation As Long, _
        ByRef pSecurityDescriptor As Byte, _
        ByVal nLenght As Long, _
        ByRef lpnLenghtNeeded As Long) _
    As Long
    
#End If

Private Declare Function PathIsNetworkPath _
Lib "shlwapi" Alias "PathIsNetworkPathA" ( _
    ByVal pszPath As String) _
As Long

Private Declare Function PathIsUNC _
Lib "shlwapi.dll" Alias "PathIsUNCA" ( _
    ByVal pszPath As String) _
As Long

Private Declare Function CreateFile _
Lib "kernel32.dll" Alias "CreateFileA" ( _
    ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByRef lpSecurityAttributes As Any, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) _
As Long




'checks if the current user has permissions for the File or folder
'returns true if the WinAPI Funktion returns 0
Public Function writeAllowed(ByVal path As String) As Boolean
    Dim retVal      As Long
    Dim lSizeNeeded As Long
    Dim bSecDesc()  As Byte
    
    Const DACL_SECURITY_INFORMATION     As Long = &H4
    Const OWNER_SECURITY_INFORMATION    As Long = &H1
    
    'first time is used to get the size
    retVal = GetFileSecurity(path, _
                            OWNER_SECURITY_INFORMATION, _
                            0, _
                            0&, _
                            lSizeNeeded)

    'resize the array
    ReDim bSecDesc(0 To lSizeNeeded) As Byte
    
    'second one will return the result of the Function
    retVal = GetFileSecurity(path, _
                             OWNER_SECURITY_INFORMATION, _
                             bSecDesc(0), _
                             lSizeNeeded, _
                             lSizeNeeded)
        
    writeAllowed = CBool(retVal)

End Function



'checks if a network/ unc File exists/ is available
Public Function networkFileExists(ByVal path As String) As Boolean
    Dim retVal      As Variant
    
    'use WinAPI Function to check if the path is a unc path
    If CBool(PathIsUNC(path)) Then

        'use CreateFile instead of OpenFile due to
        'the path length limitation of OpenFiles OFSTRUCT
        retVal = CreateFile(path, _
                            GENERIC_READ, _
                            FILE_SHARE_READ, _
                            ByVal 0&, _
                            OPEN_EXISTING, _
                            FILE_ATTRIBUTE_NORMAL, _
                            0&)

        If retVal <> -1 Then
            networkFileExists = True
        End If
        
        'close the File
        CloseHandle retVal
        
    End If
    
End Function



'checks if a folder or File path exists
'also checks if its a network File and if it is available
Public Function exists(ByVal path As String) As Boolean
        
        'if no network/ unc File
        If Not CBool(PathIsUNC(path)) Then
            'use VBA to determine existence
            exists = Dir(path, vbDirectory) <> vbNullString
        Else
            'use WinAPI Functions to determine existence
            exists = networkFileExists(path)
        End If

End Function



'get the extension of a File
Public Function extension(ByVal path As String)
    extension = Mid(path, InStrRev(path, ".", Len(path), vbTextCompare) + 1, Len(path))
End Function



'checks if a File is opened by a different user
Public Function isOpen(ByVal path As String) As Boolean
    Dim f       As Long
    Dim errnum  As Long
    
    On Error Resume Next
    f = FreeFile()
    Open path For Input Lock Read As #f
    Close f
    errnum = Err.Number
    On Error GoTo 0
    Select Case errnum
        Case 0: isOpen = False
        Case 70: isOpen = True
        Case Else: Error errnum
    End Select
    
End Function



'returns the Filename of a given path
Public Function getNameFromPath(ByVal path As String)
    Dim e As Long
    
    If Len(path) = 0 Then Exit Function
    e = InStrRev(path, "\", Len(path), vbTextCompare) + 1
    getNameFromPath = Mid(path, e, Len(path))
    
End Function



'this is the File dialog of windows
'uses WinAPI to open it instead of VBA
'not really practical...
Public Function openDialog(sTitle As String) As String
    Dim openf As OPENFILENAME
    Dim retVal As Long

    openf.lpstrFilter = ""
    openf.nFilterIndex = 1
    openf.hwndOwner = 0
    openf.lpstrFile = String(257, 0)
    #If VBA7 Then
        openf.nMaxFile = LenB(openf.lpstrFile) - 1
        openf.lStructSize = LenB(openf)
    #Else
        openf.nMaxFile = Len(openf.lpstrFile) - 1
        openf.lStructSize = Len(openf)
    #End If
    openf.lpstrFileTitle = openf.lpstrFile
    openf.nMaxFileTitle = openf.nMaxFile
    openf.lpstrInitialDir = "C:\"
    openf.lpstrTitle = sTitle
    openf.flags = 0
    retVal = GetOpenFileName(openf)

    If retVal = 0 Then
        openDialog = vbNullString
    Else
        openDialog = Trim(Left(openf.lpstrFile, InStr(1, openf.lpstrFile, vbNullChar) - 1))
    End If

End Function


'copys a file to the given destination with a new name
Public Function copyTo(ByVal path As String, ByVal destination As String, ByVal fileName As String) As Boolean
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not exists(fso.BuildPath(destination, fileName)) Then
        fso.CopyFile path, fso.BuildPath(destination, fileName), False
        copyTo = True
    End If
    
    
End Function


'reads a file and returns the contents delimited
Public Function read(ByVal path As String, ByVal delimiter As String)
    Dim f           As Long
    Dim sLine       As String
    Dim fContent    As String
    
    f = FreeFile
    Open path For Input As #f
        While Not EOF(f)
            Line Input #f, sLine
            fContent = fContent & sLine & delimiter
        Wend
    Close #f
    
    If Right(fContent, Len(delimiter)) = delimiter Then
        fContent = Left(fContent, Len(fContent) - Len(delimiter))
    End If
    
    read = fContent
    
End Function





'changes the name of a given File
'path is the complete path + Filename and extension!
'fileName = New File Name
Public Sub ChangeName(ByVal path As String, _
                      ByVal fileName As String)
    
    Dim tmp As String
    On Error Resume Next
    
    tmp = Mid(path, 1, InStrRev(path, "\", Len(path), vbTextCompare))
    Name path As tmp & fileName
    
    Err.clear
    
End Sub



'creates a new textFile
'pDestination = Destination path
'sfName = name of File + extension
Public Sub CreateText(ByVal pDestination As String, _
                     ByVal sfName As String)
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CreateTextFile (pDestination & sfName), True
    
End Sub



'simply deletes a given File
'if its a locked File, it simply does nothing
Public Sub Delete(ByVal path As String)
    
    On Error Resume Next
    Kill path
    Err.clear
    
End Sub



'adds a new line to textFile
'path is the complete Filepath + extension
'lineValue is the Line Value
Public Sub WriteLine(ByVal path As String, _
                     ByVal lineValue As String)

    Dim f As Long
    
    f = FreeFile
    Open path For Append As #f
        Print #1, lineValue
    Close #f

End Sub



'creates given folder if it doesnt exists
Public Sub CreateParent(ByVal path As String)
    
    On Error Resume Next
    If Not exists(path) Then MkDir (path)
    On Error GoTo 0
    
End Sub