none
Macro to send PDF copies via email based on a folder RRS feed

  • Question

  • I am trying to update an existing macro that is supposed to send PDF copies to different emails. 

    Right now, the macro can only send to one recipient which is hardcoded in here. But what if i have spreadsheet that contains different email addresses (Col E) . And will have different subject lines (Col F). I tried to store these colums as OBJECT but it does not work. Storing it as STRING does not work as well. 

    I do appreciate all the help I will receive! 

    Sub LWDSO_EMAIL()
    
    
    
    Dim objol As Object
    Dim objmail As Object
    Dim objFolder As Object
    Dim strFolder As String
    Dim fso As Object
    Dim fsFolder As Object
    Dim fsFile As Object
    Dim shpmntref(1 To 1000), pkup(1 To 1000), po(1 To 1000), scac(1 To 1000), Emailedto(1 To 1000) As String
    Dim subject(1 To 1000) As String
    Dim irow, arraynumber, arraynumberEnd As Variant
    
    
    '---------------------------------------------------------------------------------------
    'START OF MAIN CODE
    '---------------------------------------------------------------------------------------
    
       
        Range("F2:F100" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=CONCATENATE(B2,"" "",C2) "
          
        Columns(6).copy
        Columns(6).PasteSpecial xlPasteValues
        
        Range("F1") = "SUBJECT"
        
            
        endOfSheet = ActiveSheet.UsedRange.Rows.Count
     
    With ActiveSheet
    arraynumber = 1
     
    For irow = 2 To endOfSheet
            
      
           ' shpmntref(arraynumber) = Trim(Range("A" & irow))
           ' pkup(arraynumber) = Trim(Range("B" & irow))
           ' po(arraynumber) = Trim(Range("C" & irow))
           ' scac(arraynumber) = Trim(Range("D" & irow))
            Emailedto(arraynumber) = Trim(Range("E" & irow))
            subject(arraynumber) = Trim(Range("F" & irow))
            
             LastArray = arraynumber + 1
       
            
    Next irow
     
    LastArray = arraynumber - 1
    
        
        
        '// Create a folder browser.  Note:  You can change the last arg (the Empty) to a   //
        '// string where you want the folder browser to start in, such as: ThisWorkbook.Path//
        Set objFolder = CreateObject("Shell.Application"). _
                            BrowseForFolder( _
                                0, "Select the folder that the workbooks are in.", 0, Empty)
        
       
        
        
        On Error GoTo errhndl
        If Not objFolder Is Nothing Then
            '// Get the path to the folder user picked. //
            strFolder = objFolder.Items.Item.path
        Else
            '// In case user cancels folder browser     //
            MsgBox "Error picking a folder.", 0, ""
            Exit Sub
        End If
        
        '// Create various needed objects.  I happen to use late-binding.                   //
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fsFolder = fso.GetFolder(strFolder)
        Set objol = CreateObject("Outlook.Application")
        Set objmail = objol.CreateItem(0) '(olMailItem)
        
        With objmail
            .To = "abc@def.COM"                    'this will vary based on the spreadsheet
            .subject = "Ticket ..."                'this will vary based on the spreadsheet
            .Body = "Here's a test"
            .NoAging = True
            
            '// Using the file system object, return/add all the pdf files in the picked  //
            '// folder.                                                                     //
            For Each fsFile In fsFolder.Files
                If fsFile.Name Like "*.pdf" Then
                    .Attachments.Add strFolder & "\" & fsFile.Name
                End If
            Next
            
            .Display
            
        End With
        
    errhndl:
        Set objFolder = Nothing
        Set fso = Nothing
        Set fsFolder = Nothing
        Set objol = Nothing
        Set objmail = Nothing
    
    
    
    
    End With
    
    
    End Sub
    
    
    


    • Edited by IamJackie Thursday, January 23, 2020 4:07 PM
    Tuesday, January 21, 2020 10:57 PM

Answers

  • Here is a modified version:

    Sub LWDSO_EMAIL()
        Dim strFolder As String
        Dim fso As Object
        Dim fsFolder As Object
        Dim fsFile As Object
        Dim objOL As Object
        Dim objMail As Object
        Dim irow As Long
        Dim endofSheet As Long
    
    '------------------
    'START OF MAIN CODE
    '------------------
    
        ' Get folder path
        With Application.FileDialog(4) ' msoFileDialogFolderPicker
            .Title = "Select the folder that the workbooks are in."
            If .Show Then
                strFolder = .SelectedItems(1)
            Else
                MsgBox "Error picking a folder.", vbExclamation
                Exit Sub
            End If
        End With
    
        '// Create various needed objects.
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fsFolder = fso.GetFolder(strFolder)
    
        ' Fill column F
        Range("F1") = "SUBJECT"
        endofSheet = Range("A" & Rows.Count).End(xlUp).Row
        With Range("F2:F" & endofSheet)
            .Formula = "=CONCATENATE(B2,"" "",C2) "
            .Value = .Value
        End With
    
        ' Start Outlook
        Set objOL = CreateObject("Outlook.Application")
        ' Loop through the rows
        For irow = 2 To endofSheet
            ' Create email message
            Set objMail = objOL.CreateItem(0) ' olMailItem
            ' Set properties and display the message
            With objMail
                .To = Range("E" & irow).Value
                .subject = Range("F" & irow).Value
                .Body = "Here's a test"
                .NoAging = True
                For Each fsFile In fsFolder.Files
                    If fsFile.Name Like "*.pdf" Then
                        .Attachments.Add strFolder & "\" & fsFile.Name
                    End If
                Next fsFile
                .Display
            End With
        Next irow
    
        ' Clean up
        Set fso = Nothing
        Set fsFolder = Nothing
        Set objOL = Nothing
        Set objMail = Nothing
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by IamJackie Wednesday, January 22, 2020 9:07 PM
    Tuesday, January 21, 2020 11:51 PM
  • It's actually simpler than that:

    Sub LWDSO_EMAIL()
        Dim strFolder As String
        Dim fso As Object
        Dim fsFolder As Object
        Dim fsFile As Object
        Dim objOL As Object
        Dim objMail As Object
        Dim irow As Long
        Dim endofSheet As Long
    
    '------------------
    'START OF MAIN CODE
    '------------------
    
        ' Fixed folder path
        strFolder = "G:\PDF\FILELIST"
    
        '// Create various needed objects.
        Set fso = CreateObject("Scripting.FileSystemObject")
        …


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by IamJackie Thursday, January 23, 2020 3:52 PM
    Thursday, January 23, 2020 9:07 AM

All replies

  • Here is a modified version:

    Sub LWDSO_EMAIL()
        Dim strFolder As String
        Dim fso As Object
        Dim fsFolder As Object
        Dim fsFile As Object
        Dim objOL As Object
        Dim objMail As Object
        Dim irow As Long
        Dim endofSheet As Long
    
    '------------------
    'START OF MAIN CODE
    '------------------
    
        ' Get folder path
        With Application.FileDialog(4) ' msoFileDialogFolderPicker
            .Title = "Select the folder that the workbooks are in."
            If .Show Then
                strFolder = .SelectedItems(1)
            Else
                MsgBox "Error picking a folder.", vbExclamation
                Exit Sub
            End If
        End With
    
        '// Create various needed objects.
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fsFolder = fso.GetFolder(strFolder)
    
        ' Fill column F
        Range("F1") = "SUBJECT"
        endofSheet = Range("A" & Rows.Count).End(xlUp).Row
        With Range("F2:F" & endofSheet)
            .Formula = "=CONCATENATE(B2,"" "",C2) "
            .Value = .Value
        End With
    
        ' Start Outlook
        Set objOL = CreateObject("Outlook.Application")
        ' Loop through the rows
        For irow = 2 To endofSheet
            ' Create email message
            Set objMail = objOL.CreateItem(0) ' olMailItem
            ' Set properties and display the message
            With objMail
                .To = Range("E" & irow).Value
                .subject = Range("F" & irow).Value
                .Body = "Here's a test"
                .NoAging = True
                For Each fsFile In fsFolder.Files
                    If fsFile.Name Like "*.pdf" Then
                        .Attachments.Add strFolder & "\" & fsFile.Name
                    End If
                Next fsFile
                .Display
            End With
        Next irow
    
        ' Clean up
        Set fso = Nothing
        Set fsFolder = Nothing
        Set objOL = Nothing
        Set objMail = Nothing
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by IamJackie Wednesday, January 22, 2020 9:07 PM
    Tuesday, January 21, 2020 11:51 PM
  • Thank you so much!!! It worked! Happy dancing right now!! 
    Wednesday, January 22, 2020 9:07 PM
  • Hello Hans! 

    Out of curiosity, is it possible to hard code the file path of the folder instead of the user selecting where that folder path is?  I found a piece of code but is erroring out on this line: Set fsFolder = fso.GetFolder(strFolder)       

        'Hardcode file path
        Call ChDrive("G")
        ChDir "G:\PDF\FILELIST"

        FileToOpen = Application.GetOpenFilename _
        (Title:="Select file to import", _
        FileFilter:="PDF Files *.pdf (*.pdf),")
        ''
        
        If FileToOpen = False Then
        MsgBox "No file specified.", vbExclamation, "ERROR"
        Exit Sub
        Else
        Workbooks.Open FileName:=FileToOpen
        End If
        

        '// Create various needed objects.
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fsFolder = fso.GetFolder(strFolder)                              ' Getting an error on this line

    Wednesday, January 22, 2020 11:28 PM
  • It's actually simpler than that:

    Sub LWDSO_EMAIL()
        Dim strFolder As String
        Dim fso As Object
        Dim fsFolder As Object
        Dim fsFile As Object
        Dim objOL As Object
        Dim objMail As Object
        Dim irow As Long
        Dim endofSheet As Long
    
    '------------------
    'START OF MAIN CODE
    '------------------
    
        ' Fixed folder path
        strFolder = "G:\PDF\FILELIST"
    
        '// Create various needed objects.
        Set fso = CreateObject("Scripting.FileSystemObject")
        …


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by IamJackie Thursday, January 23, 2020 3:52 PM
    Thursday, January 23, 2020 9:07 AM
  • Thank you very much! That was awesome! I tend to overcomplicate things. :D 

    Thursday, January 23, 2020 3:53 PM