Searching for .msg files in subfolders and mailing them with Outlook using VBA Excel

Question

I am working on a project for work to automate Outlook mails with .msg attachments. Sending these mails will happen through Excel. I am using VBA Excel to do that.

In Excel I have a column with the needed emails (column T), and other column (column R) with a part of the name of .msg files. One part of the name of the files can be contained in one or more files. If more files are found, then they will be all mailed to their corresponding mail determined in column T.

I am a bit new to Excel VBA, but I have a working code which can locate these files and puts it with there path in column U (in case of two files found they get later in the code separated in columns U and V) to use the path to send it with Outlook mail at the end of the code.

The only problem I have, is that these files are distributed in subfolders and my code works only if all files are in one folder. I use (DIR$) to locate these files with wild cards. How can I optimize the code to locate the files in all subfolders instead of one folder?

Sub Send_Files()
Dim OApp As Object
Dim OMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim irow As Integer
Dim i As Integer
Dim dpath As String
Dim pfile As String
Dim FileNames As String
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim Mail_Object, OutApp As Variant
Dim OutMail As Variant

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
On Error Resume Next
irow = 1
dpath = "H:\My Documents\test\"
Do While Cells(irow, 18) <> Empty

pfile = Dir$(dpath & "\*" & Cells(irow, 18) & "*")
FileNames = ""
'MsgBox pfile

Do Until LenB(pfile) = 0
    If FileNames <> "" Then
        FileNames = FileNames & ";" & dpath & pfile
    Else
        FileNames = dpath & pfile
    End If
    pfile = Dir$
    For Each cell In Cells(irow, 18)
    Cells(irow, 21) = FileNames

    Next cell

Loop
irow = irow + 1
Loop
'Debug.Print FileNames

Application.DisplayAlerts = False
Columns("V:AU").Select
Selection.ClearContents
Columns("U:U").Select
Selection.TextToColumns Destination:=Range("U1"), DataType:=xlDelimited, _
    TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

Set sh = ActiveSheet

Set OApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("T").Cells.SpecialCells(xlCellTypeConstants)

    Set rng = sh.Cells(cell.Row, 1).Range("U1:V1")

    If cell.Value Like "?*@testmail.nl" And _
       Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OMail = OApp.CreateItem(0)

        With OMail
            .To = cell.Value
            .Body = "Hoi " & cell.Offset(0, -1).Value
            .Subject = cell.Offset(0, -2).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    '.Subject = FileCell.Value
                    End If
                End If
             Next FileCell
            .Display
            ' Application.Wait (Now + TimeValue("0:00:01"))
            ' Application.SendKeys "%z"
        End With
        Set OMail = Nothing
    End If
Next cell
  Set OApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Answer 1

First, you have a bug in your first loop

dpath = "H:\My Documents\test\"
.
pfile = Dir$(dpath & "\*" & Cells(irow, 18) & "*")

produces

H:\My Documents\test\\* & Cells(irow, 18) & "*"
                    ^^

You'll need to put your code that builds the FileNames list into a separate function and pass the path and file mask to that function.

Where your code to build that list is now, you would use another Dir$() loop to look at the files but using a . file mask. It will report back both files and directories. Then you test for the Directory attribute being set on the returned file name.

llngFileAttribute = GetAttr(<path and name from DIR$()> )
if llngFileAttribute And vbDirectory <> 0 then
    'Is a directory, so add the name from DIR$ to the path
    'and call the list building routine
else
    'call list building routine with path and mask built from cell data
end if

If you want to step multiple levels into the directory structure you will have to put the new loop in another function and make it recursive, only calling it once from your exiting code.

Answer 2

Using Dir() recursively is a bit tricky. The global Dir() function uses a single data structure for listing what it finds so if you call if from within another Dir() loop, the initial data structure gets destroyed and when you return from the recursion it isn't what you are expecting.

This could also be done with the FileSystemObject and it would be a bit more simple. But since you used Dir() in your initial code, I used that. This example finds all bit map files (*.bmp) in the folder holding the workbook and any folders under that folder.

I'll leave it to you to modify the code below for your needs and explore the FileSystemObject if you choose.

Variable declarations:

The first character is variable scope: l=local;a=argument passed in; m=member; and g=global.

There can be an optional "a" after the scope to indicate that the variable is an array of the following data type.

The next 3 characters are the data type: str=string; lng=Long; obj=Object; vnt=Variant; etc

Followed by a descriptive variable name, each word beginning with an upper case letter.

Thus, "lavntSubDirs" is a local variable that is used as an array of variants called SubDirs.

Subs have no prefix since they don't return data. Functions have a prefix indicating the returned data type.

Option Explicit

Public Sub GetFileList()
    Dim lstrStartingPath As String
    Dim lstrFileNames As String

    'Set starting path as desired
    lstrStartingPath = ThisWorkbook.Path
    'lstrStartingPath = "H:\My Documents\test

'Your row reading loop starts here and sets the 2nd parameter
    lstrFileNames = strRecurseDirs(lstrStartingPath, "*.bmp")
    'lstrFileNames = strRecurseDirs(lstrStartingPath, "*" & Cells(irow, 18) & "*")

    'remove last ";" character
    lstrFileNames = Left$(lstrFileNames, Len(lstrFileNames) - 1)

    'Use the returned string as needed
    MsgBox lstrFileNames

'End of your row reading loop
'.
'.
'.

End Sub
Private Function strRecurseDirs(astrPath As String, astrFileMask As String) As String
    Dim lstrNextDir As String
    Dim lstrFileSpec As String
    Dim llngFileAttr As Long
    Dim lstrFileNameList As String
    Dim lstrSubDirs As String
    Dim lavntSubDirs As Variant
    Dim llngSubDirIdx As Long

    'Get the file names in the passed path
    lstrFileNameList = strGetFileNames(astrPath, astrFileMask)

    'Look for child directories. Because Dir() is a global function and     it uses it's own data structure to return
    'the next item, we can't recurse from within a Dir loop. Since our     strGetFileNames() uses Dir() to find the
    'files it will trash this Dir() loop's item list. So we make a list     of directories found and then recurse for
    'each of the found directories.
    lstrNextDir = Dir(astrPath + "\*.*", vbDirectory)
    Do While Len(lstrNextDir) > 0
        'Note: "." is current directory, ".." is parent directory. We     don't want either.
        If lstrNextDir <> "." And lstrNextDir <> ".." Then
            lstrFileSpec = astrPath + "\" + lstrNextDir
            llngFileAttr = GetAttr(lstrFileSpec)
            If (llngFileAttr And vbDirectory) = vbDirectory Then
                'Is a directory so add it to list of subdirectories to examine
                lstrSubDirs = lstrSubDirs + lstrFileSpec + ";"
            End If
        End If
        lstrNextDir = Dir()
    Loop
    If Len(lstrSubDirs) Then
        'We found subdirectories so process them one at a time

        'Remove last ";" so we don't get an empty string as the last item
        lstrSubDirs = Left$(lstrSubDirs, Len(lstrSubDirs) - 1)

        'Separate the directories found into indiviual items
        lavntSubDirs = Split(lstrSubDirs, ";")

        'Process directories found
        For llngSubDirIdx = 0 To UBound(lavntSubDirs)
            lstrFileNameList = lstrFileNameList + strRecurseDirs(CStr(lavntSubDirs(llngSubDirIdx)), astrFileMask)
        Next
    End If

    strRecurseDirs = lstrFileNameList
End Function
Private Function strGetFileNames(astrPath As String, astrFileMask As String) As String
    Dim lstrFileNameList As String
    Dim lstrFileName As String
    Dim lstrFileSpec As String
    Dim llngFileAttr As Long

    lstrFileName = Dir(astrPath + "\" + astrFileMask)
    Do While Len(lstrFileName) > 0
        lstrFileSpec = astrPath + "\" + lstrFileName
        llngFileAttr = GetAttr(lstrFileSpec)
        If (llngFileAttr And vbDirectory) = 0 Then
            'Not a directory
            lstrFileNameList = lstrFileNameList + lstrFileSpec + ";"
        End If
        lstrFileName = Dir()
    Loop
    strGetFileNames = lstrFileNameList
End Function