VBA File Handling/ Simple Filesystem Module

    • VBA: Sonstige

    Es gibt 1 Antwort in diesem Thema. Der letzte Beitrag () ist von VaporiZed.

      VBA File Handling/ Simple Filesystem Module

      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

      1. Option Explicit
      2. Option Private Module
      3. '_______________________________________________________________________________________
      4. '
      5. ' For OpenFile function
      6. '_______________________________________________________________________________________
      7. Private Const OFS_MAXPATHNAME As Long = 128 'maximum length of whole Filename
      8. Private Const OF_EXIST As Long = &H4000
      9. Private Type OFSTRUCT
      10. cBytes As Byte
      11. fFixedDisk As Byte
      12. nErrCode As Integer
      13. Reserved1 As Integer
      14. Reserved2 As Integer
      15. szPathName(OFS_MAXPATHNAME) As Byte
      16. End Type
      17. '_______________________________________________________________________________________
      18. '
      19. ' For CreateFile function
      20. '_______________________________________________________________________________________
      21. 'CreateFile dwDesiredAccess
      22. Private Const GENERIC_READ As Long = &H80000000 'read only
      23. Private Const GENERIC_WRITE As Long = &H40000000 'write only
      24. 'CreateFile dwShareMode
      25. Private Const FILE_SHARE_READ As Long = &H1
      26. Private Const FILE_SHARE_WRITE As Long = &H2
      27. 'CreateFile dwCreationDisposition
      28. Private Const CREATE_NEW As Long = 1 'create if not exists
      29. Private Const CREATE_ALWAYS As Long = 2 'create and override
      30. Private Const OPEN_ALWAYS As Long = 4 'open and create if not exists
      31. Private Const OPEN_EXISTING As Long = 3 'open existing File
      32. Private Const TRUNCATE_EXISTING As Long = 5 'open existing and delete content
      33. 'CreateFile dwFlagsAndAttributes
      34. Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20 'archived
      35. Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2 'hidden
      36. Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80 'normal
      37. Private Const FILE_ATTRIBUTE_READONLY As Long = &H1 'read only File
      38. Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4 'SystemFile
      39. Private Const FILE_FLAG_DELETE_ON_CLOSE As Long = &H4000000 'delete after closing
      40. Private Const FILE_FLAG_NO_BUFFERING As Long = &H20000000 'using no buffer/cache
      41. Private Const FILE_FLAG_OVERLAPPED As Long = &H40000000 'allow parallel read write (not on Win95, 98, CE)
      42. Private Const FILE_FLAG_POSIX_SEMANTICS As Long = &H1000000 'Case-Sensitive Filename
      43. Private Const FILE_FLAG_RANDOM_ACCESS As Long = &H10000000 'buffer for random access
      44. Private Const FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000 'buffer for sequential access
      45. Private Const FILE_FLAG_WRITE_THROUGH As Long = &H80000000 'no physical cache -> direct write
      46. #If VBA7 Then
      47. Private Declare PtrSafe Function GetOpenFileName _
      48. Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
      49. ByRef pOpenFilename As OPENFILENAME) _
      50. As Long
      51. Private Type OPENFILENAME
      52. lStructSize As Long
      53. hwndOwner As LongPtr
      54. hInstance As LongPtr
      55. lpstrFilter As String
      56. lpstrCustomFilter As String
      57. nMaxCustFilter As Long
      58. nFilterIndex As Long
      59. lpstrFile As String
      60. nMaxFile As Long
      61. lpstrFileTitle As String
      62. nMaxFileTitle As Long
      63. lpstrInitialDir As String
      64. lpstrTitle As String
      65. flags As Long
      66. nFileOffset As Integer
      67. nFileExtension As Integer
      68. lpstrDefExt As String
      69. lCustData As LongPtr
      70. lpfnHook As LongPtr
      71. lpTemplateName As String
      72. End Type
      73. #Else
      74. Public Declare Function GetOpenFileName _
      75. Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
      76. ByRef pOpenFilename As OPENFILENAME) _
      77. As Long
      78. Private Type OPENFILENAME
      79. lStructSize As Long
      80. hwndOwner As Long
      81. hInstance As Long
      82. lpstrFilter As String
      83. lpstrCustomFilter As String
      84. nMaxCustFilter As Long
      85. nFilterIndex As Long
      86. lpstrFile As String
      87. nMaxFile As Long
      88. lpstrFileTitle As String
      89. nMaxFileTitle As Long
      90. lpstrInitialDir As String
      91. lpstrTitle As String
      92. flags As Long
      93. nFileOffset As Integer
      94. nFileExtension As Integer
      95. lpstrDefExt As String
      96. lCustData As Long
      97. lpfnHook As Long
      98. lpTemplateName As String
      99. End Type
      100. #End If
      101. #If Win64 Then
      102. Private Declare PtrSafe Function CloseHandle _
      103. Lib "kernel32.dll" ( _
      104. ByVal hObject As Long) _
      105. As Long
      106. Private Declare PtrSafe Function openFile _
      107. Lib "kernel32.dll" Alias _
      108. "OpenFile" (ByVal lpFileName As _
      109. String, ByRef lpReOpenBuffer As _
      110. OFSTRUCT, ByVal wStyle As _
      111. Long) As Long
      112. Private Declare PtrSafe Function GetFileSecurity _
      113. Lib "advapi32.dll" Alias "GetFileSecurityA" ( _
      114. ByVal lpFileName As String, _
      115. ByVal RequestedInformation As Long, _
      116. ByRef pSecurityDescriptor As Byte, _
      117. ByVal nLenght As Long, _
      118. ByRef lpnLenghtNeeded As Long) _
      119. As Long
      120. #Else
      121. Private Declare Function CloseHandle _
      122. Lib "kernel32.dll" ( _
      123. ByVal hObject As Long) _
      124. As Long
      125. Private Declare Function openFile _
      126. Lib "kernel32.dll" Alias _
      127. "OpenFile" (ByVal lpFileName As _
      128. String, ByRef lpReOpenBuff As _
      129. OFSTRUCT, ByVal wStyle As _
      130. Long) As Long
      131. Private Declare Function GetFileSecurity _
      132. Lib "advapi32.dll" Alias "GetFileSecurityA" ( _
      133. ByVal lpFileName As String, _
      134. ByVal RequestedInformation As Long, _
      135. ByRef pSecurityDescriptor As Byte, _
      136. ByVal nLenght As Long, _
      137. ByRef lpnLenghtNeeded As Long) _
      138. As Long
      139. #End If
      140. Private Declare Function PathIsNetworkPath _
      141. Lib "shlwapi" Alias "PathIsNetworkPathA" ( _
      142. ByVal pszPath As String) _
      143. As Long
      144. Private Declare Function PathIsUNC _
      145. Lib "shlwapi.dll" Alias "PathIsUNCA" ( _
      146. ByVal pszPath As String) _
      147. As Long
      148. Private Declare Function CreateFile _
      149. Lib "kernel32.dll" Alias "CreateFileA" ( _
      150. ByVal lpFileName As String, _
      151. ByVal dwDesiredAccess As Long, _
      152. ByVal dwShareMode As Long, _
      153. ByRef lpSecurityAttributes As Any, _
      154. ByVal dwCreationDisposition As Long, _
      155. ByVal dwFlagsAndAttributes As Long, _
      156. ByVal hTemplateFile As Long) _
      157. As Long
      158. 'checks if the current user has permissions for the File or folder
      159. 'returns true if the WinAPI Funktion returns 0
      160. Public Function writeAllowed(ByVal path As String) As Boolean
      161. Dim retVal As Long
      162. Dim lSizeNeeded As Long
      163. Dim bSecDesc() As Byte
      164. Const DACL_SECURITY_INFORMATION As Long = &H4
      165. Const OWNER_SECURITY_INFORMATION As Long = &H1
      166. 'first time is used to get the size
      167. retVal = GetFileSecurity(path, _
      168. OWNER_SECURITY_INFORMATION, _
      169. 0, _
      170. 0&, _
      171. lSizeNeeded)
      172. 'resize the array
      173. ReDim bSecDesc(0 To lSizeNeeded) As Byte
      174. 'second one will return the result of the Function
      175. retVal = GetFileSecurity(path, _
      176. OWNER_SECURITY_INFORMATION, _
      177. bSecDesc(0), _
      178. lSizeNeeded, _
      179. lSizeNeeded)
      180. writeAllowed = CBool(retVal)
      181. End Function
      182. 'checks if a network/ unc File exists/ is available
      183. Public Function networkFileExists(ByVal path As String) As Boolean
      184. Dim retVal As Variant
      185. 'use WinAPI Function to check if the path is a unc path
      186. If CBool(PathIsUNC(path)) Then
      187. 'use CreateFile instead of OpenFile due to
      188. 'the path length limitation of OpenFiles OFSTRUCT
      189. retVal = CreateFile(path, _
      190. GENERIC_READ, _
      191. FILE_SHARE_READ, _
      192. ByVal 0&, _
      193. OPEN_EXISTING, _
      194. FILE_ATTRIBUTE_NORMAL, _
      195. 0&)
      196. If retVal <> -1 Then
      197. networkFileExists = True
      198. End If
      199. 'close the File
      200. CloseHandle retVal
      201. End If
      202. End Function
      203. 'checks if a folder or File path exists
      204. 'also checks if its a network File and if it is available
      205. Public Function exists(ByVal path As String) As Boolean
      206. 'if no network/ unc File
      207. If Not CBool(PathIsUNC(path)) Then
      208. 'use VBA to determine existence
      209. exists = Dir(path, vbDirectory) <> vbNullString
      210. Else
      211. 'use WinAPI Functions to determine existence
      212. exists = networkFileExists(path)
      213. End If
      214. End Function
      215. 'get the extension of a File
      216. Public Function extension(ByVal path As String)
      217. extension = Mid(path, InStrRev(path, ".", Len(path), vbTextCompare) + 1, Len(path))
      218. End Function
      219. 'checks if a File is opened by a different user
      220. Public Function isOpen(ByVal path As String) As Boolean
      221. Dim f As Long
      222. Dim errnum As Long
      223. On Error Resume Next
      224. f = FreeFile()
      225. Open path For Input Lock Read As #f
      226. Close f
      227. errnum = Err.Number
      228. On Error GoTo 0
      229. Select Case errnum
      230. Case 0: isOpen = False
      231. Case 70: isOpen = True
      232. Case Else: Error errnum
      233. End Select
      234. End Function
      235. 'returns the Filename of a given path
      236. Public Function getNameFromPath(ByVal path As String)
      237. Dim e As Long
      238. If Len(path) = 0 Then Exit Function
      239. e = InStrRev(path, "\", Len(path), vbTextCompare) + 1
      240. getNameFromPath = Mid(path, e, Len(path))
      241. End Function
      242. 'this is the File dialog of windows
      243. 'uses WinAPI to open it instead of VBA
      244. 'not really practical...
      245. Public Function openDialog(sTitle As String) As String
      246. Dim openf As OPENFILENAME
      247. Dim retVal As Long
      248. openf.lpstrFilter = ""
      249. openf.nFilterIndex = 1
      250. openf.hwndOwner = 0
      251. openf.lpstrFile = String(257, 0)
      252. #If VBA7 Then
      253. openf.nMaxFile = LenB(openf.lpstrFile) - 1
      254. openf.lStructSize = LenB(openf)
      255. #Else
      256. openf.nMaxFile = Len(openf.lpstrFile) - 1
      257. openf.lStructSize = Len(openf)
      258. #End If
      259. openf.lpstrFileTitle = openf.lpstrFile
      260. openf.nMaxFileTitle = openf.nMaxFile
      261. openf.lpstrInitialDir = "C:\"
      262. openf.lpstrTitle = sTitle
      263. openf.flags = 0
      264. retVal = GetOpenFileName(openf)
      265. If retVal = 0 Then
      266. openDialog = vbNullString
      267. Else
      268. openDialog = Trim(Left(openf.lpstrFile, InStr(1, openf.lpstrFile, vbNullChar) - 1))
      269. End If
      270. End Function
      271. 'copys a file to the given destination with a new name
      272. Public Function copyTo(ByVal path As String, ByVal destination As String, ByVal fileName As String) As Boolean
      273. Dim fso As Object
      274. Set fso = CreateObject("Scripting.FileSystemObject")
      275. If Not exists(fso.BuildPath(destination, fileName)) Then
      276. fso.CopyFile path, fso.BuildPath(destination, fileName), False
      277. copyTo = True
      278. End If
      279. End Function
      280. 'reads a file and returns the contents delimited
      281. Public Function read(ByVal path As String, ByVal delimiter As String)
      282. Dim f As Long
      283. Dim sLine As String
      284. Dim fContent As String
      285. f = FreeFile
      286. Open path For Input As #f
      287. While Not EOF(f)
      288. Line Input #f, sLine
      289. fContent = fContent & sLine & delimiter
      290. Wend
      291. Close #f
      292. If Right(fContent, Len(delimiter)) = delimiter Then
      293. fContent = Left(fContent, Len(fContent) - Len(delimiter))
      294. End If
      295. read = fContent
      296. End Function
      297. 'changes the name of a given File
      298. 'path is the complete path + Filename and extension!
      299. 'fileName = New File Name
      300. Public Sub ChangeName(ByVal path As String, _
      301. ByVal fileName As String)
      302. Dim tmp As String
      303. On Error Resume Next
      304. tmp = Mid(path, 1, InStrRev(path, "\", Len(path), vbTextCompare))
      305. Name path As tmp & fileName
      306. Err.clear
      307. End Sub
      308. 'creates a new textFile
      309. 'pDestination = Destination path
      310. 'sfName = name of File + extension
      311. Public Sub CreateText(ByVal pDestination As String, _
      312. ByVal sfName As String)
      313. Dim fso As Object
      314. Set fso = CreateObject("Scripting.FileSystemObject")
      315. fso.CreateTextFile (pDestination & sfName), True
      316. End Sub
      317. 'simply deletes a given File
      318. 'if its a locked File, it simply does nothing
      319. Public Sub Delete(ByVal path As String)
      320. On Error Resume Next
      321. Kill path
      322. Err.clear
      323. End Sub
      324. 'adds a new line to textFile
      325. 'path is the complete Filepath + extension
      326. 'lineValue is the Line Value
      327. Public Sub WriteLine(ByVal path As String, _
      328. ByVal lineValue As String)
      329. Dim f As Long
      330. f = FreeFile
      331. Open path For Append As #f
      332. Print #1, lineValue
      333. Close #f
      334. End Sub
      335. 'creates given folder if it doesnt exists
      336. Public Sub CreateParent(ByVal path As String)
      337. On Error Resume Next
      338. If Not exists(path) Then MkDir (path)
      339. On Error GoTo 0
      340. End Sub

      Dateien
      • File.bas

        (13,52 kB, 8 mal heruntergeladen, zuletzt: )
      • Doku_WindowsAPI.pdf

        (382,76 kB, 21 mal heruntergeladen, zuletzt: )

      Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „Petersilie“ ()

      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.
      Dieser Beitrag wurde bereits 5 mal editiert, zuletzt von „VaporiZed“, mal wieder aus Grammatikgründen.

      Häufig von mir verwendete Abkürzungen: CEs = control elements (Labels, Buttons, DGVs, ...) und tDS (typisiertes DataSet)
      Aufgrund spontaner Selbsteintrübung sind all meine Glaskugeln beim Hersteller. Lasst mich daher bitte nicht in den Spekulatiusmodus gehen.