none
VBA code to search documents from listed folders and sub-folders? RRS feed

  • Question

  • I've listed code where it searches and attaches documents to email. The name value is listed in column A24. Everything works just fine except the below folder path does not look into subfolders; it only picks up and attaches the files if it's listed in the main folder. I tried putting '& "\"' in the formula for dpath, but still it didn't work. Can anyone suggest any alternate way to script into folders and subfoders?

    My current VBA code is below:


    Set obMail = Outlook.CreateItem(olMailItem)
    With obMail
    .To="email@comapny.com"
    .Subject ="O/S Blanace"
    .BodyFormat = olFormatPlain
    .Body ="Please see attached files"

    irow
    =24‘initialize row index from 24
    DoWhile Cells(irow,1)<> Empty
    'pikcing up file name from column A
    pfile 
    = Dir(dpath &"\*"& Cells(irow,1)&"*")
    'checking for file exist in a folder and if its a pdf file

    If pfile <>""And Right(pfile,3)="pdf"Then
    .Attachments.Add (dpath &"\"& pfile)
    EndIf

    ‘go to next file listed on the A column
    irow 
    = irow +1
    Loop

    .Send
    EndWith
    • Edited by PraSon Tuesday, March 6, 2018 10:08 PM Corrected the previous code and removed the errors
    Thursday, February 22, 2018 5:43 AM

Answers

  • You need a recursive routine to search subfolders.  Below is a routine to recursively search a folder and populate an array.  Run this first and use the array.

    Dim pathArr() As String
    Dim first As Boolean
    
    Function Recurse(sPath As String, searchFor As String)
    
      Dim fso As New FileSystemObject  '  Reference Microsoft Scripting Runtime
      Dim myFolder As Folder
      Dim mySubFolder As Folder
      Dim myFile As File
      
      Set myFolder = fso.GetFolder(sPath)
      For Each mySubFolder In myFolder.SubFolders
        For Each myFile In mySubFolder.Files
          If InStr(myFile.Name, searchFor) > 0 Then
            Debug.Print myFile
            If first Then
              pathArr(UBound(pathArr)) = myFile
              first = False
            Else
              ReDim Preserve pathArr(UBound(pathArr) + 1)
              pathArr(UBound(pathArr)) = myFile
            End If
          End If
        Next myFile
        Recurse = Recurse(mySubFolder.Path, searchFor)
      Next
    End Function
    
    Sub TestR()
        ReDim pathArr(0)
        first = True
        Call Recurse("C:\mydir", ".pdf")
    End Sub
    
    
    

    • Marked as answer by PraSon Thursday, March 22, 2018 2:13 AM
    Friday, February 23, 2018 2:38 AM

All replies

  • Hi,

    I don't use Outlook, and have no idea about folders Outlook are using.
    Do you have privilege to access to all folders under "dpath"?  

    Regards,

    Ashidacchi

    Thursday, February 22, 2018 6:36 AM
  • @Ashidacchi, As I mentioned above my dpath code works for the file listed in master folder but does not look for files in sub-folders. 

    Friday, February 23, 2018 12:42 AM
  • Don't you see syntax errors in the above code you provided?
    There are two "Do While" loops but one "Loop" can be seen. (If statement is not completed also)

    Please provide the latest code with using Code Block.
        
     

    Ashidacchi

    Friday, February 23, 2018 1:04 AM
  • You need a recursive routine to search subfolders.  Below is a routine to recursively search a folder and populate an array.  Run this first and use the array.

    Dim pathArr() As String
    Dim first As Boolean
    
    Function Recurse(sPath As String, searchFor As String)
    
      Dim fso As New FileSystemObject  '  Reference Microsoft Scripting Runtime
      Dim myFolder As Folder
      Dim mySubFolder As Folder
      Dim myFile As File
      
      Set myFolder = fso.GetFolder(sPath)
      For Each mySubFolder In myFolder.SubFolders
        For Each myFile In mySubFolder.Files
          If InStr(myFile.Name, searchFor) > 0 Then
            Debug.Print myFile
            If first Then
              pathArr(UBound(pathArr)) = myFile
              first = False
            Else
              ReDim Preserve pathArr(UBound(pathArr) + 1)
              pathArr(UBound(pathArr)) = myFile
            End If
          End If
        Next myFile
        Recurse = Recurse(mySubFolder.Path, searchFor)
      Next
    End Function
    
    Sub TestR()
        ReDim pathArr(0)
        first = True
        Call Recurse("C:\mydir", ".pdf")
    End Sub
    
    
    

    • Marked as answer by PraSon Thursday, March 22, 2018 2:13 AM
    Friday, February 23, 2018 2:38 AM
  • Hi Ashidacchi, 

    I've updated the code with correct script. But still its not looping through the subfolders

    Tuesday, March 6, 2018 10:09 PM
  • Hi PraSon,

    I didn't provide any code in this thread.
    I'm afraid you must confuse mogulman52 and me.

    Regards,

    Ashidacchi >> http://hokusosha.com/

    Tuesday, March 6, 2018 10:17 PM
  • Hi, 

    could you help how to put apply this to my current code? 

    Set obMail = Outlook.CreateItem(olMailItem)
    With obMail
    .To="email@comapny.com"
    .Subject ="O/S Blanace"
    .BodyFormat = olFormatPlain
    .Body ="Please see attached files"

    irow
    =24‘initialize row index from 24
    DoWhile Cells(irow,1)<> Empty
    'pikcing up file name from column A
    pfile 
    = Dir(dpath &"\*"& Cells(irow,1)&"*")
    'checking for file exist in a folder and if its a pdf file

    If pfile <>""And Right(pfile,3)="pdf"Then
    .Attachments.Add (dpath &"\"& pfile)
    EndIf

    ‘go to next file listed on the A column
    irow 
    = irow +1
    Loop

    .Send
    EndWith

    Wednesday, March 7, 2018 5:53 AM
  • Can you describe your folder structure and what you want to do.  Give specific examples.  It is hard to understand from your code.
    Wednesday, March 7, 2018 11:26 PM
  • Sub EmailTheFile()
    
    Dim obMail As Outlook.MailItem
    Dim irow As Integer
    Dim pfile As String
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set Folder = fso.GetFolder("C:\Users\VBA_Testing_Folder\")
        Set obMail = Outlook.CreateItem(olMailItem)
    
        'Loop through all files and send mail
                irow = 26
                Sheets("AR Form").Select
                Range("A1:H62").Select
    
                'Creating an email
            With obMail
                 .To = Range("B18").Value
                 .Subject = "Outstanding Balance"
                 .HTMLBody = "Testing" 'RangetoHTML(rng)
    
                 'looping and attaching the File listed in cell A26 and onwards
                 Do While Cells(irow, 1) <> Empty
    
                    pfile = Dir(Folder & "\" & Cells(irow, 1) & "*")
    
                    If pfile <> "" And Right(pfile, 3) = "pdf" Then
                    .Attachments.Add (Folder & "\" & pfile)
                    End If
    
                    If pfile <> "" And Right(pfile, 3) = "xls" Then
                    .Attachments.Add (Folder & "\" & pfile)
                    End If
    
                    irow = irow + 1
                 Loop
    
                 .Display
                 .Send
            End With
    End Sub
    Tuesday, March 13, 2018 6:15 AM