This module contains a few useful VBA file and folder functions. I've lifted most of this from StackOverflow and Mr Excel and other forums, it's all fairly simple stuff.
'modFile
'v1.05 2013-09-20 13:33
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com
' DGF Help Contact: see BPMHelpContact module
'=========================================================================
'===========================================================================
' modFile
'===========================================================================
' Provides various VBA file & folder functions
'===========================================================================
' Additional modules required:
'===========================================================================
' None
'===========================================================================
' Additional References required:
'===========================================================================
' None
'===========================================================================
' External applications required:
'===========================================================================
' None
'=========================================================================
' VERSION HISTORY
'=========================================================================
' v1.05 mfLoopThroughFilesInAFolder: bugfix for NewerThan and variable name change
' v1.04 mfLoopThroughFilesInAFolder: function reports back Variant
' mfLoopThroughFilesInAFolder: will count pattern matches
' v1.03a annotations only
' v1.03 added mfLoopThroughFilesInAFolder
' added mfGetDateCreated
' v1.02a annotations only
' v1.02 addded mfGetFileExtension
' v1.01 added mf prefix to macronames
'************************************************************************
' v1.00 created from Allen Browne original code
Option Explicit
Function mfFileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
' bFindFolders. If strFile is a folder, mfFileExists() returns False unless this argument is True.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Dim lngAttributes As Long
'Include read-only files, hidden files, system files.
lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
If bFindFolders Then
lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
Else
'Strip any trailing slash, so Dir does not look inside the folder.
Do While Right$(strFile, 1) = "\"
strFile = Left$(strFile, Len(strFile) - 1)
Loop
End If
'If Dir() returns something, the file exists.
On Error Resume Next
mfFileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
Function mfFolderExists(strPath As String) As Boolean
On Error Resume Next
mfFolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
Function mfTrailingSlash(varIn As Variant) As String
If Len(varIn) > 0 Then
If Right(varIn, 1) = "\" Then
mfTrailingSlash = varIn
Else
mfTrailingSlash = varIn & "\"
End If
End If
End Function
Function mfGetFileExtension(ByVal mfFileName As String) As String
'v1.02 2013-04-12 14:58
'reports characters after and including the LAST fullstop/period
'e.g. "File Name v3.45.xlsm" result is ".xlsm"
Const cPrd As String = "."
Dim b As Byte, c As Byte, pp As String, tt As String
b = InStr(1, mfFileName, cPrd) 'find first period in string
If b = 0 Then
'no periods found = no file extension
mfGetFileExtension = cPrd
Else
'make sure b is the last period in string
c = b
Do Until c = 0
c = InStr(b + 1, mfFileName, cPrd)
If c <> 0 Then b = c
Loop
mfGetFileExtension = cPrd & Right(mfFileName, Len(mfFileName) - b)
End If
End Function
Function mfGetDateCreated(ByVal mfPathAndFileName As String) As Double
'v1.03 2013-07-18 16:05
'source: http://www.mrexcel.com/forum/excel-questions/73458-read-external-file-properties-date-created-using-visual-basic-applications.html
Dim oFS As Object
'This creates an instance of the MS Scripting Runtime FileSystemObject class
Set oFS = CreateObject("Scripting.FileSystemObject")
'MsgBox mfPathAndFileName & " was created on " & oFS.GetFile(mfPathAndFileName).DateCreated
mfGetDateCreated = oFS.GetFile(mfPathAndFileName).DateCreated
Set oFS = Nothing
End Function
Function mfLoopThroughFilesInAFolder(ByVal mfPath As String _
, Optional ByVal mfSearchString As String = "" _
, Optional ByVal mfNewestFile As Boolean = False, Optional ByVal mfNewestFileNewerThan As Double _
, Optional ByVal mfCountMatches As Boolean)
'v1.05 2013-09-20 13:33
'original source: http://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba
'searches in order of variables specified, only ever searches one variable
'Usage:
' if mfSearchString is specified, searches for pattern match in filename
' if mfNewestFile is specified, searches for newest file created
' if mfCountMatches is True, counts pattern matches, mfSearchString is also required
' NB: mfNewestFileNewerThan [i.e. Now()] should also be specified as a validity check for search range
Const cBsl As String = "\"
If Right(mfPath, 1) <> cBsl Then mfPath = mfPath & cBsl
Dim mfFile As Variant
If mfSearchString = "" And mfNewestFile = False Then 'mfFilenameMinLen = 0 And
MsgBox "Must search for filename string OR minimum length of filename OR look for newest file"
Exit Function
ElseIf mfSearchString <> "" Then
'search for pattern match
If mfCountMatches Then
'count pattern matches
mfFile = Dir(mfPath)
While (mfFile <> "")
If InStr(mfFile, mfSearchString) > 0 Then
'MsgBox "found by pattern match: " & mfPath & mfFile
mfLoopThroughFilesInAFolder = mfLoopThroughFilesInAFolder + 1
End If
mfFile = Dir
Wend
Else
'find first file
mfFile = Dir(mfPath)
While (mfFile <> "")
If InStr(mfFile, mfSearchString) > 0 Then
'MsgBox "found by pattern match: " & mfPath & mfFile
mfLoopThroughFilesInAFolder = mfPath & mfFile
Exit Function
End If
mfFile = Dir
Wend
End If
'ElseIf mfFilenameMinLen <> 0 Then 'can't see why this would ever be used
' mfFile = Dir(mfPath)
' While (mfFile <> "")
' If Len(mfFile) > 0 Then
' 'MsgBox "found by min length of filename: " & mfPath & mfFile
' mfLoopThroughFilesInAFolder = mfPath & mfFile
' Exit Function
' End If
' mfFile = Dir
' Wend
ElseIf mfNewestFile = True Then
'search for newest file
Dim mfCDthisfile As Double, mfCDnewest As Double
mfFile = Dir(mfPath)
If mfFile = "" Then GoTo ErrorHandler 'catches errors if no files found in path
On Error GoTo ErrorHandler 'catches errors if path invalid or some other error in mfGetDateCreated
mfCDthisfile = mfGetDateCreated(mfPath & mfFile)
If mfNewestFileNewerThan = 0 Then mfCDnewest = mfCDthisfile Else mfCDnewest = mfNewestFileNewerThan 'helps to limit searching for newer files than this one
On Error GoTo 0
While (mfFile <> "")
mfCDthisfile = mfGetDateCreated(mfPath & mfFile)
If mfCDthisfile > mfCDnewest Then
mfCDnewest = mfCDthisfile
mfLoopThroughFilesInAFolder = mfPath & mfFile 'always newest file, .PART file is created FIRST
End If
mfFile = Dir
Wend
'NB: returns "" if no newest file found
End If
Exit Function
ErrorHandler:
MsgBox "Error in mfLoopThroughFilesInAFolder: no files found in path" & vbLf & vbLf & mfPath
End Function
No comments:
Post a Comment