Individually generate email content and attached all files from folder based on cell

[aloy78]

Hi Guys/Gals,

I would like to be able to generate an email based on clicking on a cell (e.g. L3) in a certain column (L). The macro will retrieve cell values from the row (3) and put them in the email and also attach files found in the folder file path in that same row. So if I click cell (L4), it will retrieve cell values from row (4) and so forth. Any help is very much appreciated.



A

B
C
D
E
F
G
H
I
J
K
L


1














2

Order date
Status
Email Subject
Email Body
Invoice#
No. of Pkg
Kg
Shipped Date
Client email Address
Folder File Path
Click to sent email


3

1/12
Order complete
REF: Your Order 2016-REF 01
Dear Sir/Mdm,
Your order has been process. Please take note of:
2016-REF 01
1
14
1/12
abby@test.com; david@test.com
C:\Order\2016\2016-REF 01
email


4

1/12
sending
REF: Your Order 2016-REF 02
Dear Sir,
Your order has been process. Please take note of:
2016-REF 02
1
14
3/12
danny@test.com
C:\Order\2016\2016-REF 02
email






Email sample generate will look something like this:


To: abby@test.com; david@test.com
Cc:
Subject: REF: Your Order 2016-REF 01
Attachment: Your invoice 2016-REF 01.doc, (files from the folder C:\Order\2016\2016-REF 01)
Operating Manual.pdf, (files from the folder C:\Order\2016\2016-REF 01)
Receipt of acknowledgement.doc (files from the folder C:\Order\2016\2016-REF 01)

Dear Mdm,
Your order has been process. Please take note of:17860

Invoice #: 2016-REF 01
No. of Pkgs: 1
Weight Kg: 14
Date Shipped Out: 01/12/2016

Thank You.

[bho]

Hopefully this might work for you (or at least get you started)...

'Add reference to Microsoft Outlook xx.x Object Library

Dim oApp as Object
Dim oMail as Object
Dim x as long
x = 1

Do Until x = Sheet1.UsedRange.Rows.Count
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)

With oMail
.To = Sheet1.Cells(x, 10)
.Subject = Sheet1.Cells(x, 4)
.body = Sheet1.Cells(x, 5)
.Attachments.Add Sheet1.Cells(x, 11)
.Send
End With
x = x + 1
Loop

Set oApp=Nothing
Set oMail=Nothing

[Kenneth Hobs]

First, add this to a Module. It is a standard method that I use for batching files or folders.

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found."
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function

Add the Outlook object in Tools > References as commented. Change Display to Send once you are happy with how it works.

Right click your sheet's tab, View Code, and paste this. This fires the Selection event to do what you want.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range, rw&, a
With Target
If .Column <> 12 Or .Row < 3 Then Exit Sub
rw = .Row
a = aFFs(Cells(rw, "K"), "/a-d") 'List files only.
If Not IsArray(a) Then Exit Sub
Iemail a, rw
End With
End Sub


'Add reference: Microsoft Outlook xx.x Library, where xx.x is 14.0, 15.0, 16.0, etc.
Private Sub Iemail(aList, tr As Long)
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim v, s(1 To 8) As String

Set olApp = New Outlook.Application

Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = Cells(tr, "J")
.Subject = Cells(tr, "D")
s(1) = Cells(tr, "E")
s(2) = ""
s(3) = "Invoice #: " & Cells(tr, "F")
s(4) = "No. of Pkgs: " & Cells(tr, "G")
s(5) = "Weight Kg: " & Cells(tr, "H")
s(6) = "Date Shipped Out: " & _
Format(Cells(tr, "I"), "dd/mm/yyyy")
s(7) = ""
s(8) = "Thank You."
.Body = Join(s, vbCrLf)
For Each v In aList
.Attachments.Add v
Next v
.Display
'.Send
End With

Set olMail = Nothing
Set olApp = Nothing
End Sub

[aloy78]

Hi Kenneth Hobs,
Thank you very much for the scripts and instructions. Did that and it works great. Appreciate it very much. Terima Kasih.