Consulting

Results 1 to 4 of 4

Thread: VBA Help: Email attachment via folder or direct-link

  1. #1
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location

    VBA Help: Email attachment via folder or direct-link

    Hi, I need someone help.
    I dont know any vb code. Possible if someone could help me merge this code into 1 (highlighted in red)?

    This is how the idea is.
    Col H will use/check either Folder or Direct Full link

    IF Folder path found, it will attach all files from the folder
    IF direct-link found, it will attach the file
    IF no link found, it will just send email as normal

    A B C D E F G H
    S/N TO CC Subject Greeting Body Text Signature Path of Attachment folder / Direct Link
    1 C:\Users\ABC\Desktop\SavedFolder\Folder1\
    *all attach all files found in folder
    2 C:\Users\ABC\Desktop\SavedFolder\Folder2\abc.pdf
    * or direct path - can be jpg, pdf, zip, doc*


    Sub SendEmail3()
        Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
        Dim wks As Worksheet, wPath As String, wFile As Variant
    
        'START of confirmation message box'
        response = MsgBox("Start sending email?", vbYesNo)
        If response = vbNo Then
            MsgBox ("Macro Canceled!")
            Exit Sub
        End If
        'END of confirmation message box'
        
        lr = Cells(Rows.Count, "B").End(xlUp).Row
        Set Mail_Object = CreateObject("Outlook.Application")
        Set wks = Worksheets("SendEmail_MOD2")  'worksheet name
        For i = 2 To lr
            With Mail_Object.CreateItem(o)
                .To = wks.Range("B" & i).Value
                .CC = wks.Range("C" & i).Value
                '.BCC = wks.Range("G" & I).Value    'G is refer to column G in excel
                .Subject = wks.Range("D" & i).Value
                
                .Body = wks.Range("E" & i).Value & vbNewLine & _
                wks.Range("F" & i).Value & vbNewLine & _
                wks.Range("G" & i).Value
                
                If wks.Range("I" & i).Value <> "" Then
                .Attachments.Add Range("I" & i).Value
               End If
               
                wPath = wks.Range("H" & i).Value
                If Right(wPath, 1) <> "" Then wPath = wPath & ""
                If Dir(wPath, vbDirectory) <> "" Then
                    wFile = Dir(wPath & "*.*")
                    Do While wFile <> ""
                        .Attachments.Add wPath & wFile
                        wFile = Dir()
                    Loop
                End If
                
                'Send
                .display 'disable display and enable send to send automatically
                Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
            End With
        Next i
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
        Set Mail_Object = Nothing
    End Sub

  2. #2
    The following will do what you asked
    Option Explicit
    
    Sub SendEmail4()
    'Graham Mayor - https://www.gmayor.com - Last updated - 17 Jul 2019
    Dim i As Integer
    Dim olApp As Object
    Dim olMailItem As Object
    Dim lngLastRow As Long
    Dim wks As Worksheet
    Dim strPath As String
    Dim strFile As String
    Dim lngResponse As Long
    Dim oFSO As Object
    
    
        'START of confirmation message box'
        lngResponse = MsgBox("Start sending email?", vbYesNo)
        If lngResponse = vbNo Then
            MsgBox ("Macro Canceled!")
            Exit Sub
        End If
        'END of confirmation message box'
    
    
        Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    
        Set olApp = CreateObject("Outlook.Application")
        Set wks = Worksheets("SendEmail_MOD2")  'worksheet name
        lngLastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
        For i = 2 To lngLastRow
            Set olMailItem = olApp.createitem(0)
            With olMailItem
                .To = wks.Range("B" & i).value
                .CC = wks.Range("C" & i).value
                '.BCC = wks.Range("G" & I).Value    'G is refer to column G in excel
                .display    'disable display and enable send to send automatically
    
    
                .Subject = wks.Range("D" & i).value
    
    
                .Body = wks.Range("E" & i).value & vbNewLine & _
                        wks.Range("F" & i).value & vbNewLine & _
                        wks.Range("G" & i).value
    
    
                If wks.Range("I" & i).value <> "" Then
                    .Attachments.Add Range("I" & i).value
                End If
    
    
                strPath = wks.Range("H" & i).value
                If Right(strPath, 1) = Chr(92) Then    'value is a folder
                    If Dir(strPath, vbDirectory) <> "" Then
                        strFile = Dir(strPath & "*.*")
                        Do While strFile <> ""
                            .Attachments.Add strPath & strFile, , 1
                            strFile = Dir()
                        Loop
                    End If
                Else
                    If oFSO.FileExists(strPath) Then
                        .Attachments.Add strPath, , 1
                    End If
                End If
    
    
                '.Send
                Application.Wait (Now + TimeValue("0:00:03"))    'Pausing an application for 3s, before next email
            End With
        Next i
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
        Set olApp = Nothing
        Set olMailItem = Nothing
        Set oFSO = Nothing
        Set wks = Nothing
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location
    omg! It work great and i notice it actually check the attached files size too.

    Ehhh can i had a request?

    I like to put status at Col I

    This below is for .send (mode), as i got alot of email to send. So it better not to use .display as it will had many pop-up or abort

    if email
    exceed server size, it will ABORT SEND EMAIL than state (remark: exceed server size) at Col I and process the next email.
    wrong file path, , it will ABORT SEND EMAIL than state (remark: wrong file path) at Col I and process the next email.
    wrong folder path, , it will ABORT SEND EMAIL than state (remark: wrong folder path) at Col I and process the next email.
    email send, than state (remark: email send!) at Col I and process the next email.

    email send mean
    - server size ok or
    - files path ok or
    - folder path ok or
    - no link found at Col H

    Remark at Col I
    Offset(, 8).Value = "exceed server size" 'attached files exceed server size <-- can put colour in red?
    Offset(, 8).Value = "wrong file path " 'Path file wrong <-- can put colour in red?
    Offset(, 8).Value = "wrong folder path " 'Path folder wrong <-- can put colour in red?
    Offset(, 8).Value = "email send!" 'successful send email
    Quote Originally Posted by gmayor View Post
    The following will do what you asked
    Option Explicit
    
    Sub SendEmail4()
    'Graham Mayor - https://www.gmayor.com - Last updated - 17 Jul 2019
    Dim i As Integer
    Dim olApp As Object
    Dim olMailItem As Object
    Dim lngLastRow As Long
    Dim wks As Worksheet
    Dim strPath As String
    Dim strFile As String
    Dim lngResponse As Long
    Dim oFSO As Object
    
    
        'START of confirmation message box'
        lngResponse = MsgBox("Start sending email?", vbYesNo)
        If lngResponse = vbNo Then
            MsgBox ("Macro Canceled!")
            Exit Sub
        End If
        'END of confirmation message box'
    
    
        Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    
        Set olApp = CreateObject("Outlook.Application")
        Set wks = Worksheets("SendEmail_MOD2")  'worksheet name
        lngLastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
        For i = 2 To lngLastRow
            Set olMailItem = olApp.createitem(0)
            With olMailItem
                .To = wks.Range("B" & i).value
                .CC = wks.Range("C" & i).value
                '.BCC = wks.Range("G" & I).Value    'G is refer to column G in excel
                .display    'disable display and enable send to send automatically
    
    
                .Subject = wks.Range("D" & i).value
    
    
                .Body = wks.Range("E" & i).value & vbNewLine & _
                        wks.Range("F" & i).value & vbNewLine & _
                        wks.Range("G" & i).value
    
    
                If wks.Range("I" & i).value <> "" Then
                    .Attachments.Add Range("I" & i).value
                End If
    
    
                strPath = wks.Range("H" & i).value
                If Right(strPath, 1) = Chr(92) Then    'value is a folder
                    If Dir(strPath, vbDirectory) <> "" Then
                        strFile = Dir(strPath & "*.*")
                        Do While strFile <> ""
                            .Attachments.Add strPath & strFile, , 1
                            strFile = Dir()
                        Loop
                    End If
                Else
                    If oFSO.FileExists(strPath) Then
                        .Attachments.Add strPath, , 1
                    End If
                End If
    
    
                '.Send
                Application.Wait (Now + TimeValue("0:00:03"))    'Pausing an application for 3s, before next email
            End With
        Next i
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
        Set olApp = Nothing
        Set olMailItem = Nothing
        Set oFSO = Nothing
        Set wks = Nothing
    End Sub
    Last edited by harky; 07-17-2019 at 10:17 AM.

  4. #4
    VBAX Regular
    Joined
    Oct 2017
    Posts
    18
    Location
    hi, my request had been solved. Thanks

Posting Permissions

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