Monday 5 August 2013

VBA Modules: modFile v1.05

Read this for full information on these modules

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