How to combine TraversePath function to email VBA code?

[prason]

[FONT=&quot]Can someone help me to combine mail merge attachment VBA code with looping folder and sub-folders code? I've tried out few options and its either shows error by sending emails without the attachments or doesn't finds attachment due to the location in sub-folders. [/FONT]

[FONT=&quot]**My mail merge code is here:**
[/FONT][FONT=&quot] Sub EmailTheFile()[/FONT]

[FONT=&quot] Dim obMail As Outlook.MailItem[/FONT]
[FONT=&quot] Dim irow As Integer[/FONT]
[FONT=&quot] Dim pfile As String[/FONT]
[FONT=&quot] Set fso = CreateObject("Scripting.FileSystemObject")[/FONT]
[FONT=&quot] Set Folder = fso.GetFolder("C:\Users\VBA_Testing_Folder")[/FONT]
[FONT=&quot] Set obMail = Outlook.CreateItem(olMailItem)[/FONT]

[FONT=&quot] 'Loop through all files and send mail[/FONT]
[FONT=&quot] irow = 26[/FONT]
[FONT=&quot] Sheets("AR Form").Select[/FONT]
[FONT=&quot] Range("A1:H62").Select[/FONT]

[FONT=&quot] 'Creating an email[/FONT]
[FONT=&quot] With obMail[/FONT]
[FONT=&quot] .To = Range("B18").Value[/FONT]
[FONT=&quot] .Subject = "Outstanding Balance"[/FONT]
[FONT=&quot] .HTMLBody = "Testing" 'RangetoHTML(rng)[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'looping and attaching the File listed in cell A26 and onwards[/FONT]
[FONT=&quot] Do While Cells(irow, 1) <> Empty[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] pfile = Dir(Folder & "" & Cells(irow, 1) & "*")[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] If pfile <> "" And Right(pfile, 3) = "pdf" Then[/FONT]
[FONT=&quot] .Attachments.Add (Folder & "" & pfile)[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] If pfile <> "" And Right(pfile, 3) = "xls" Then[/FONT]
[FONT=&quot] .Attachments.Add (Folder & "" & pfile)[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] irow = irow + 1[/FONT]
[FONT=&quot] Loop[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] .Display[/FONT]
[FONT=&quot] .Send[/FONT]
[FONT=&quot] End With[/FONT]
[FONT=&quot] End Sub

[/FONT][FONT=&quot]**Now I want to combine above code with TraversePath function**[/FONT]
[FONT=&quot]---------------------------------------------------------------[/FONT]


[FONT=&quot] Sub TraversePath12(path As String)[/FONT]
[FONT=&quot] Dim currentPath As String, directory As Variant[/FONT]
[FONT=&quot] Dim dirCollection As Collection[/FONT]
[FONT=&quot] Set dirCollection = New Collection[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] currentPath = Dir(path, vbDirectory)[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Explore current directory[/FONT]
[FONT=&quot] Do Until currentPath = vbNullString[/FONT]
[FONT=&quot] Debug.Print currentPath[/FONT]
[FONT=&quot] If Left(currentPath, 1) <> "." And _[/FONT]
[FONT=&quot] (GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then[/FONT]
[FONT=&quot] dirCollection.Add currentPath[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] currentPath = Dir()[/FONT]
[FONT=&quot] Loop[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot] 'Explore subsequent directories[/FONT]
[FONT=&quot] For Each directory In dirCollection[/FONT]
[FONT=&quot] Debug.Print "---SubDirectory: " & directory & "---"[/FONT]
[FONT=&quot] TraversePath path & directory & ""[/FONT]
[FONT=&quot] Next directory[/FONT]
[FONT=&quot] End Sub[/FONT]

[FONT=&quot] Sub Test12()[/FONT]
[FONT=&quot] TraversePath12 "C:\Users\VBA_Testing_Folder"[/FONT]
[FONT=&quot] End Sub[/FONT]

 

[Worf]

Welcome to the Board

' Excel module
Sub EmailTheFiles()
Dim obMail As MailItem, r%, fs$, f
Sheets("AR Form").Activate
fs = "c:\pub\"                                                    ' starting folder
f = Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & _
fs & """ /b/s").StdOut.ReadAll, vbCrLf)                           ' all sub folders
[a:a].ClearContents
[a1].Resize(UBound(f)).Value = Application.WorksheetFunction.Transpose(f)
Set obMail = Outlook.CreateItem(olMailItem)
r = 1
With obMail
    .To = [b18]
    .Subject = "Outstanding Balance"
    .HTMLBody = "Testing"
    Do While Cells(r, 1) <> Empty And r < 200
        If Right(Cells(r, 1), 4) = ".pdf" Then .Attachments.Add Cells(r, 1).Value
        r = r + 1
    Loop
    .Display
End With
End Sub

 

[prason]

Hi Worf,

Thanks for the help. It worked like a charm. but the only thing it did was picked up all the file from the folder and sub-folders and attached it to an email instead listed ones on AR form. And i think it did that because it copy pasted all the file names from both folders and sub-folders and listed on AR FORM sheet.
Is there a way it can do that without copy pasting the file names on the spreadsheet?
Again.. thanks a lot.. this is really a break through for me

 

[Worf]

• Indeed, my example attaches all PDF files on the directory tree. This version includes only the listed files. It is done without writing to the spreadsheet.

' Excel module
Sub EmailTheFiles()
Dim obMail As MailItem, i%, fs$, f, v, rng As Range
Sheets("AR Form").Activate
fs = "d:\pub\"                                                    ' starting folder
f = Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & _
fs & """ /b/s").StdOut.ReadAll, vbCrLf)                           ' all sub folders
Set obMail = Outlook.CreateItem(olMailItem)
With obMail
    .To = [b18]
    .Subject = "Outstanding Balance"
    .HTMLBody = "Testing"
    For i = 1 To UBound(f)
        If Len(f(i)) Then
            v = Split(f(i), "\")
            Set rng = [a:a].Find(v(UBound(v)), [a1], xlValues)
            If Not rng Is Nothing Then .Attachments.Add f(i)
        End If
    Next
    .Display
End With
End Sub

 

[prason]

Wow..you are amazing... thank you for the quick reply. it did work on first bit where it didn't list any files on my spredsheet (tht was GREAT!!) But than it didn't attached anything to my email . My file names are listed on AR Form sheet on Row A26 to A39 and I tried to change your code from i=26 and yet it didn't work . I'm sorry that I've been keep coming back to you. But so far you are the only one who has showed me how to work on this. Whatever you see in my prior script i've learned it by myself and trying to work out this last bit where it looks for file listed on A26 - A39 column and attach it to an email. But i was keep failing Hope you can help one last time.. Again thanks for all your help.