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
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.
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
Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „Petersilie“ ()