File Modul: Code, Test und Mappe

+ PermissionGranted(ByVal pName As String) As Boolean
+ NetworkFileExists(ByVal pName As String) As Boolean
+ Exists(ByVal pName As String) As Boolean
+ Extension(ByVal pName As String)
+ IsOpen(ByVal pName As String) As Boolean
+ GetNameFromPath(ByVal pName As String)
+ OpenDialog(sTitle As String) As String
- Declare PtrSafe Function GetOpenFileName
- Declare Function GetOpenFileName
- Declare PtrSafe Function CloseHandle
- Declare PtrSafe Function OpenFile
- Declare PtrSafe Function GetFileSecurity
- Declare Function CloseHandle
- Declare Function OpenFile
- Declare Function GetFileSecurity
- Declare Function PathIsNetworkPath
- Declare Function PathIsUNC

+ ChangeName(ByVal pName As String, nFileName As String)
+ CopyTo(ByVal pName As String, _
ByVal pDestination As String, _
Optional ByVal nFileName As String = vbNullString)
+ CreateTxt(ByVal pDestination As String, ByVal sfName As String)
+ Delete(ByVal pName As String)
+ WriteLine(ByVal pName As String, ByVal lValue As String)
+ CreateParent(ByVal pName As String)

Option Explicit
Private Const OFS_MAXPATHNAME   As Long = 128
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
#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" ( _
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" ( _
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
' Functions
Public Function PermissionGranted(ByVal pName 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
retVal = GetFileSecurity(pName, _
OWNER_SECURITY_INFORMATION, _
0, _
0&, _
lSizeNeeded)
ReDim bSecDesc(0 To lSizeNeeded) As Byte
retVal = GetFileSecurity(pName, _
OWNER_SECURITY_INFORMATION, _
bSecDesc(0), _
lSizeNeeded, _
lSizeNeeded)
PermissionGranted = CBool(retVal)
End Function
Public Function NetworkFileExists(ByVal pName As String) As Boolean
Dim retVal As Variant
Dim strucFname As OFSTRUCT
If CBool(PathIsUNC(pName)) Then
retVal = OpenFile(pName, strucFname, OF_EXIST)
If retVal  -1 Then
NetworkFileExists = True
End If
CloseHandle retVal
End If
End Function
Public Function Exists(ByVal pName As String) As Boolean
If Not CBool(PathIsUNC(pName)) Then
Exists = Dir(pName, vbDirectory)  vbNullString
Else
Exists = NetworkFileExists(pName)
End If
End Function
Public Function Extension(ByVal pName As String)
Extension = Mid(pName, InStrRev(pName, ".", Len(pName), vbTextCompare) + 1, Len(pName))
End Function
Public Function IsOpen(ByVal pName As String) As Boolean
Dim f       As Long
Dim errnum  As Long
On Error Resume Next
f = FreeFile()
Open pName 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
Public Function GetNameFromPath(ByVal pName As String)
Dim s As Long, e As Long
If Len(pName) = 0 Then Exit Function
e = InStrRev(pName, "\", Len(pName), vbTextCompare) + 1
GetNameFromPath = Mid(pName, e, Len(pName) - e - 3)
End Function
' Subs
Public Sub ChangeName(ByVal pName As String, _
ByVal nFileName As String)
Dim tmp As String
On Error Resume Next
tmp = Mid(pName, 1, InStrRev(pName, "\", Len(pName), vbTextCompare))
Name pName As tmp & nFileName
Err.Clear
End Sub
Public Sub CopyTo(ByVal pName As String, _
ByVal pDestination As String, _
Optional ByVal nFileName As String = vbNullString)
Dim tmp As String
If nFileName  vbNullString Then
tmp = Right(pDestination, InStrRev(pDestination, "\", Len(pDestination), vbTextCompare)) _
If InStr(1, pDestination, "\", vbTextCompare) = 0 Then Exit Sub
If InStrRev(tmp, ".", Len(tmp), vbTextCompare) > 0 Then Exit Sub
tmp = tmp & nFileName
pDestination = tmp
End If
On Error Resume Next
FileCopy pName, pDestination
End Sub
Public Sub CreateTxt(ByVal pDestination As String, _
ByVal sfName As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile (pDestination & sfName), True
End Sub
Public Sub Delete(ByVal pName As String)
On Error Resume Next
Kill pName
Err.Clear
End Sub
Public Sub WriteLine(ByVal pName As String, _
ByVal lValue As String)
Dim f As Long
f = FreeFile
Open pName For Append As #f
Print #1, lValue
Close #f
End Sub
Public Sub CreateParent(ByVal pName As String)
If Not Exists(pName) Then MkDir (pName)
End Sub
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

Option Explicit
Sub TestPermission()
'Vollzugriff auf Datei
End Sub
Sub a()
Dim pfmParent As String
Dim pTestFile As String
Dim cpTstFile As String
Dim cpNamFile As String
Dim pWinSys As String
Dim pThis   As String
pWinSys = "C:\Windows\System32\AgentService.exe"
pThis = ThisWorkbook.FullName
pfmParent = "C:\FileModuleTestFolder\"
pTestFile = "TestFileText.txt"
cpTstFile = pfmParent & pTestFile
Debug.Print "===================================================="
Debug.Print "===     Testing the file permission function     ==="
Debug.Print "===================================================="
Debug.Print "All Permissions granted for File '" & pWinSys & "'" & vbTab & vbTab & "= " &  _
File.PermissionGranted(pWinSys)
Debug.Print "All Permissions granted for File '" & pThis & "'" & vbTab & "= " & File. _
PermissionGranted(pThis)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===          Creating Folder and File            ==="
Debug.Print "===================================================="
File.CreateParent pfmParent
Debug.Print "Created Parent: " & vbTab & vbTab & pfmParent
File.CreateTxt pfmParent, pTestFile
Debug.Print "Created new Textfile: " & vbTab & pTestFile
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===          File Exists/ Is UNC File            ==="
Debug.Print "===================================================="
Debug.Print "File really exists '" & cpTstFile & "'" & vbTab & "= " & File.Exists(cpTstFile) _
Debug.Print "File is Network File '" & cpTstFile & "' = " & File.NetworkFileExists( _
cpTstFile)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===             Extracting some Data             ==="
Debug.Print "===================================================="
Debug.Print "Filename of Path '" & cpTstFile & "' is: " & File.GetNameFromPath(cpTstFile)
Debug.Print "Extension = " & File.Extension(cpTstFile)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===               Accessability                  ==="
Debug.Print "===================================================="
Debug.Print "File is Opened by a User = " & File.IsOpen(cpTstFile)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===                   Renaming                   ==="
Debug.Print "===================================================="
File.ChangeName cpTstFile, "ChangedTextfileName.txt"
cpTstFile = pfmParent & "ChangedTextfileName.txt"
Debug.Print "Renamed file to: " & cpTstFile
Debug.Print "File (" & cpTstFile & ") Exists = " & File.Exists(cpTstFile)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===                   Copying                    ==="
Debug.Print "===================================================="
cpNamFile = Environ("Userprofile") & "\desktop\NewTextfileName.txt"
File.CopyTo cpTstFile, cpNamFile
Debug.Print "Created a copy of '" & cpTstFile
Debug.Print "Copy Exists (" & cpNamFile & ") = " & File.Exists(cpNamFile)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===                   Writing                    ==="
Debug.Print "===================================================="
Debug.Print "Writing 'Hello World' in File: " & cpTstFile
File.WriteLine cpTstFile, "Hello World"
Debug.Print "Open File '" & cpTstFile & "' to check if writing was successfull"
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===               Deleting Files                 ==="
Debug.Print "===================================================="
Debug.Print "Deleting Copy and Original:"
File.Delete cpNamFile
Debug.Print cpNamFile & "has been deleted "
Debug.Print "File Exists (" & cpNamFile & ") = " & File.Exists(cpNamFile)
Debug.Print
File.Delete cpTstFile
Debug.Print cpTstFile & "has been deleted "
Debug.Print "File Exists(" & cpTstFile & ") = " & File.Exists(cpTstFile)
Debug.Print
Debug.Print
Debug.Print
Debug.Print "===================================================="
Debug.Print "===        Opening/ Creating FileDialog          ==="
Debug.Print "===================================================="
Debug.Print "Opening FileDialog:"
File.OpenDialog ("FileDialog Successfull")
End Sub

===     Testing the file permission function     ===
All Permissions granted for File 'C:\Windows\System32\AgentService.exe'     = Falsch
All Permissions granted for File 'C:\Users\ich\Documents\FileTest.xlsm'   = Wahr
===          Creating Folder and File            ===
Created Parent:         C:\FileModuleTestFolder\
Created new Textfile:   TestFileText.txt
===          File Exists/ Is UNC File            ===
File really exists 'C:\FileModuleTestFolder\TestFileText.txt'   = Wahr
File is Network File 'C:\FileModuleTestFolder\TestFileText.txt' = Falsch
===             Extracting some Data             ===
Filename of Path 'C:\FileModuleTestFolder\TestFileText.txt' is: TestFileText
Extension = txt
===               Accessability                  ===
File is Opened by a User = Falsch
===                   Renaming                   ===
Renamed file to: C:\FileModuleTestFolder\ChangedTextfileName.txt
File (C:\FileModuleTestFolder\ChangedTextfileName.txt) Exists = Wahr
===                   Copying                    ===
Created a copy of 'C:\FileModuleTestFolder\ChangedTextfileName.txt
Copy Exists (C:\Users\ich\desktop\NewTextfileName.txt) = Wahr
===                   Writing                    ===
Writing 'Hello World' in File: C:\FileModuleTestFolder\ChangedTextfileName.txt
Open File 'C:\FileModuleTestFolder\ChangedTextfileName.txt' to check if writing was successfull
===               Deleting Files                 ===
Deleting Copy and Original:
C:\Users\ich\desktop\NewTextfileName.txthas been deleted
File Exists (C:\Users\ich\desktop\NewTextfileName.txt) = Falsch
C:\FileModuleTestFolder\ChangedTextfileName.txthas been deleted
File Exists(C:\FileModuleTestFolder\ChangedTextfileName.txt) = Falsch
===        Opening/ Creating FileDialog          ===
Opening FileDialog: