VBA File Handling/ Simple Filesystem Module

Petersilie · 7. August 2018, 17:47

VBA Modul Code für simple und grundlegende Datei und Dateisystem Operationen.

Ich nenne das Modul in welchem der Code läuft grundsätzlich 'File'
Natürlich ist jedem die Benennung selbst überlassen.

Im Anhang noch im bas Format.

Sollte jemandem auffallen, dass was bei den API Implementationen nicht stimmt, freue ich mich sehr über Feedback, Tipps, etc.
Auch freue ich mich, über Erweiterungsvorschläge.

@VaporiZed Vielen Dank für den Hinweis!
Habe die Namen angepasst und Code und Datei geupdated.
Der Code ist nun im Spoiler.

Den Auskommentierten Code habe ich rausgenommen, dabei hat es sich um eine FileCopy version gehandelt
ohne FileSystemObject. Habe mich am Ende aber doch für die mit FileSystemObject entschlossen.

Eine kleine PDF zum Thema WinAPI Funktionen ist nun auch dabei.
Dort sind einige API Funktionen auch mit Links zu Microsoft Dokus hinterlegt und
kleine Beispiele der Implementation in Bildform.

Spoiler anzeigen

Visual Basic-Quellcode

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

VaporiZed · 8. August 2018, 17:40

Nur beim Durchscrollen ins Auge gestochen: Zeile#86 stimmt nicht: ~~GetOpefileNameA~~ GetOpenfileNameA; und somit besser in Z#85 auch besser korrigieren - obwohl es dort natürlich ein eigener Name ist.
Was ist mit dem Teil ab Z#424? Auskommentierter Code klingt immer nach: "Ich trau mich nicht, den zu reaktivieren."

Alles ggf. besser in nen Spoiler rein. Ist ja doch umfangreich.

VBA File Handling/ Simple Filesystem Module

VBA File Handling/ Simple Filesystem Module

Visual Basic-Quellcode

Tags

Ähnliche Themen

2 Benutzer haben hier geschrieben