Results 1 to 15 of 15
  1. #1
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts

    Macro to attach the excel files that resides under a particular directory

    Dear Experts,

    I am a beginner with VB and looking for some help with the macros.
    I have around 50 excel files that resides under a particular directory. I am looking for a macro to attach every individual excel file to a new email message.

    For example: if there are 10 files in that directory then 10 different email drafts with the attachments should be created.

    Pls help.

    Thanks

  2. #2
    2 Star Lounger
    Join Date
    Feb 2015
    Posts
    128
    Thanks
    19
    Thanked 1 Time in 1 Post
    Hi Raj,

    The below link will help you to accomplish your task.

    http://www.slipstick.com/developer/m...d-files-email/

    If you want to see each mail then change the code -

    .send

    to

    .display

    Regards,
    JD

  3. The Following User Says Thank You to Jaggi For This Useful Post:

    rajsarv14 (2016-06-04)

  4. #3
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Dear Jaggi,

    Thanks for your time in helping me.. Do I need to do any other setting prior to running the micro.

    I changed the directory path and the email address in the code. But, it did not send any emails. Pls advise.

    The modified code I tried as below
    Dim fldName As String
    Sub SendFilesbuEmail()
    ' From http://slipstick.me/njpnx
    Dim sFName As String
    i = 0
    fldName = "C:\Users\temp\2016-05-13_17_33_11"
    sFName = Dir(fldName)
    Do While Len(sFName) > 0
    Call SendasAttachment(sFName)
    sFName = Dir
    i = i + 1
    Debug.Print fName
    Loop
    MsgBox i & " files were sent"

    End Sub

    Function SendasAttachment(fName As String)

    Dim olApp As Outlook.Application
    Dim olMsg As Outlook.MailItem
    Dim olAtt As Outlook.Attachments

    Set olApp = Outlook.Application
    Set olMsg = olApp.CreateItem(0) ' email
    Set olAtt = olMsg.Attachments

    ' attach file
    olAtt.Add (fldName & fName)

    ' send message
    With olMsg
    .Subject = "Here's that file you wanted"
    .To = "XXXXXXX@XXXXXXXX"
    .HTMLBody = "Hi " & olMsg.To & ", <br /><br /> I have attached " & fName & " as you requested."
    .Send
    '.display
    End With

    End Function
    Last edited by rajsarv14; 2016-06-03 at 11:02.

  5. #4
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,832
    Thanks
    136
    Thanked 484 Times in 461 Posts
    Hi

    ..are you sending each file to a different email address???

    If you could post a workbook with some dummy data, it would help us to help you.

    zeddy

  6. #5
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Hi Zeddy,

    Yes there are 50 different excel files under the directory. Each file has to be sent to different set of email addresses.
    Attached is the sample file.

  7. #6
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Hi Zeddy,

    Yes there are 50 different excel files under the directory. Each file has to be sent to different set of email addresses.

  8. #7
    Star Lounger Graham Mayor's Avatar
    Join Date
    Mar 2016
    Location
    Cyprus
    Posts
    68
    Thanks
    0
    Thanked 24 Times in 24 Posts
    Your message gives no indication of where the e-mail addresses are to come from. The code you posted, which doesn't work, has only one dummy address. The following, which does work, also sends to a fixed (dummy) address. You will need to pass the e-mail address to the function in order to send to different addresses

    Code:
    Option Explicit
    
    Sub SendFilesByEmail()
    ' From http://slipstick.me/njpnx
    ' as modified by Graham Mayor - http://www.gmayor.com
    Dim sFName As String
    Dim i As Integer
    Dim olApp As Object
    Dim oFSO As Object
    
    Const fldName As String = "C:\Users\temp\2016-05-13_17_33_11\"    'don't forget the backslash
    
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Not oFSO.FolderExists(fldName) Then
            MsgBox "The folder '" & fldName & "' does not exist"
            GoTo lbl_Exit
        End If
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If Err.Number <> 0 Then
            'Outlook wasn't running, start it from code
            MsgBox "This function is much faster and more reliable if Outlook is already running." & vbCr & _
                   "Start Outlook and run the macro again"
            Set olApp = Nothing
            GoTo lbl_Exit
        End If
        i = 0
        sFName = Dir(fldName)
        Do While Len(sFName) > 0
            Call SendasAttachment(fldName & sFName)    'send the path and filename
            sFName = Dir
            i = i + 1
            DoEvents
        Loop
        MsgBox i & " files were sent"
    lbl_Exit:
        Set oFSO = Nothing
        Exit Sub
    End Sub
    
    Function SendasAttachment(fname As String)
    ' Graham Mayor - http://www.gmayor.com
    Dim olApp As Object
    Dim olMsg As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    
        On Error GoTo lbl_Exit
        Set olApp = GetObject(, "Outlook.Application")
        Set olMsg = olApp.CreateItem(0)    ' email
    
        On Error Resume Next
    
        ' send message
        With olMsg
            .BodyFormat = 2
            .To = "someone@somewhere.com"
            .Subject = "Here's that file you wanted"
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            'Preserve the default signature
            oRng.Collapse 1
            'as we added the path to the variable, remove it as it is not relevant to the message
            oRng.Text = "Hi " & olMsg.To & "," & vbCr & vbCr & "I have attached " & _
                        Mid(fname, InStrRev(fname, Chr(92)) + 1) & " as you requested."
            .attachments.Add fname
            .Display
            .send
        End With
    lbl_Exit:
        'Clean up
        Set olMsg = Nothing
        Set olApp = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Function
    End Function
    Graham Mayor - Word MVP
    http://www.gmayor.com

  9. The Following User Says Thank You to Graham Mayor For This Useful Post:

    rajsarv14 (2016-06-04)

  10. #8
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    thanks for your time Mayor. It works great and fits my needs.
    Is it possible to include the directory as input from the user. If it does not exist then throw error message else do the actions.
    Pls advise.

    Many thanks

  11. #9
    Star Lounger Graham Mayor's Avatar
    Join Date
    Mar 2016
    Location
    Cyprus
    Posts
    68
    Thanks
    0
    Thanked 24 Times in 24 Posts
    You could add the Browseforfolder function from my web site - http://www.gmayor.com/useful_vba_functions.htm to the module and replace the line
    Code:
    Const fldName As String = "C:\Users\temp\2016-05-13_17_33_11\"
    with
    Code:
    Dim fldName as String
    fldName = BrowseForFolder("Select the folder with the files to be attached.")
    Graham Mayor - Word MVP
    http://www.gmayor.com

  12. The Following User Says Thank You to Graham Mayor For This Useful Post:

    rajsarv14 (2016-06-05)

  13. #10
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    After replacing it gives the error Sub or Function not defined error.

  14. #11
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    ok..checking

  15. #12
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Many thanks Mayor. Works great.
    Your site is great and will be more useful .

  16. #13
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Thanks .. I am trying to do certain actions in all the files under the directory before attaching it to the email.
    I am trying the insert the Browseforfolder function into the below code and then do the file attachment to the email.
    Below is code of actions.
    *****************
    sub test()
    Dim wb As Workbook, ws As Worksheet, r As Range
    Dim arr As Variant, d As Object
    Dim x
    Dim fldName as String
    fldName = BrowseForFolder("Select the folder with the files to be worked.")

    For Each wb In Workbooks
    wb.Activate

    Columns("D").Select
    Cells.Replace What:="admin", Replacement:="ADMIN", LookAt:=xlPart, SearchOrder _
    :=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False


    x = Range("d" & Rows.Count).End(xlUp).Row
    x = Filter(Evaluate("transpose(if(countif(offset(d2:d" & x & ",,,row(1:" & x & ")),d2:d" & _
    x & ")=1,d2:d" & x & "&f2:f" & x & ",char(2)))"), Chr(2), 0)
    If UBound(x) > -1 Then
    [g2].Resize(UBound(x) + 1).Value = Application.Transpose(x)
    End If
    For Each ws In wb.Worksheets
    ' To bold the string that appears before the character "-"
    For Each r In ws.Range("g1", ws.Range("g" & Rows.Count).End(xlUp))
    If r.Value Like "*-*" Then r.Characters(1, InStrRev(r.Value, "-") - 1).Font.Bold = True

    ' To check the values in col A,B,C and D. If it's NULL in all columns then entire Row will be deleted.
    On Error Resume Next
    Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.De lete

    ' To clear contents in column F and adjust columnwidth in columns F & G
    Columns("F").ClearContents
    Columns("F").ColumnWidth = 10
    Columns("G").ColumnWidth = 100

    Set d = CreateObject("scripting.dictionary"): d.comparemode = 1
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr) 'Assuming Row1 is the header row and data starts from row2
    arr(i, 1) = ""
    If arr(i, 2) <> "" Then d(arr(i, 2)) = ""
    Next
    k = d.keys: i = 1
    For Each c In k
    d(c) = i: i = i + 1
    Next
    For i = 2 To UBound(arr) 'Assuming Row1 is the header row and data starts from row2
    Cells(i, 1) = d(arr(i, 2))
    Next
    Next

    Next

    wb.Save

    Next
    End Sub


    Pls advise how to merge these two together.. thanks..

  17. #14
    Star Lounger Graham Mayor's Avatar
    Join Date
    Mar 2016
    Location
    Cyprus
    Posts
    68
    Thanks
    0
    Thanked 24 Times in 24 Posts
    The folder is selected in the first macro I posted, so you can create a macro to process each workbook before you attach it, and call that from that original macro.

    Code:
    Do While Len(sFName) > 0
            Call ProcessWorkBook(fldName & sFName)      'Call your new macro process
            Call SendasAttachment(fldName & sFName)    'send the path and filename
            sFName = Dir
            i = i + 1
            DoEvents
        Loop
    Start your macro as below. I am not going to attempt to decipher the Test macro you posted, but if it works on the current workbook, it should work on the workbook you open from your code. Make sure that the workbook is saved and closed at the completion of your macro, and before the first macro attaches it to the message.

    Code:
    Sub ProcessWorkBook(strWorkbook As String)
    Dim wb As Workbook, ws As Worksheet, r As Range
    Dim arr As Variant, d As Object
    Dim x
    
        Set wb = Workbooks.Open(strWorkbook)
        'Do stuff with the workbook 'wb'
    Graham Mayor - Word MVP
    http://www.gmayor.com

  18. The Following User Says Thank You to Graham Mayor For This Useful Post:

    rajsarv14 (2016-06-07)

  19. #15
    New Lounger
    Join Date
    Jun 2016
    Posts
    16
    Thanks
    5
    Thanked 0 Times in 0 Posts
    Great. Thank U for your time.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •