how to email attachement thru a given cell

[rakesh seebaruth]

hi there

i have 12 Sub Mail from Sub Mail_ John1() to Sub Mail_ Peter12(). Each individuals have their respectives email addresses. i would like to club all these 12 sub mail(Sub Mail_ John1() to Sub Mail_ Peter12() ) into one single sub Mail. Let's assume that if cell I25=JOHN then email attachment to "john@intnet.mu" . If cell I25=PETER then email attachment to ''peter@intnet.mu'' and so on with the rest. Can you please amend my <acronym title="visual basic for applications">vba</acronym> codes with highlighted in bold. Your help would be much appreciated. thanks for your help


Sub Mail_John1()

Range("b2") = Format(Date, "dd/mmmm/yyyy")

Const mydrive = "R:"

Const mydir = "Credit Admin\Seebaruth Rakesh\SEARCHES NO SIGNATURE"

Dim myname As String

Dim ss As String

myname = Sheets("sheet1").Range("e5").Text & Format(Date, "dd-mmm-yy") & ".xls"

ss = mydrive & "\" & mydir & "\" & myname & ".xls"

Application.DisplayAlerts = False

ActiveWorkbook.SaveCopyAs Filename:=ss

Application.DisplayAlerts = True

Dim i As Long, c As Range

For i = 1 To 2

Set c = Application.InputBox("Click in the cell to insert the Signature", Type:=8)

ActiveSheet.Pictures.Insert ("R:\Credit Admin\Seebaruth Rakesh\rakesh searches\sign.bmp")

With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)

.LockAspectRatio = False

.Top = c.Top

.Left = c.Left

.Height = c.RowHeight

.Width = c.Width

End With

Next i

ActiveSheet.Protect "budget", True, True

Const mydrives = "R:"

Const mydirs = "Credit Admin\Seebaruth Rakesh\rakesh searches\2014"

Dim mynames As String

Dim ms As String

Dim OutApp As Object

Dim OutMail As Object

mynames = Sheets("sheet1").Range("e5").Text & Format(Date, "dd-mmm-yy") & ".xls"

ms = mydrives & "\" & mydirs & "\" & mynames & ".xls"

Application.DisplayAlerts = False

ActiveWorkbook.SaveCopyAs Filename:=ms

Application.DisplayAlerts = True

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

With OutMail

.To = "john@intnet.mu"

.CC = ""

.BCC = ""

.Subject = Range("e5")

.Attachments.Add ms

.Send

End With

On Error GoTo 0

Set OutMail = Nothing

Set OutApp = Nothing

ThisWorkbook.Saved = True

Application.Quit

End Sub