Auto-Send Email from Excel question

[tvoltagg]

Hye guys, have another dilemma hopefully you can help me with..

I have a sheet that emails specific tabs from a different file to the people listed on the sheet. It works fine, but here's my problem:

I can either send:
ONE email, with one file, with multiple tabs to John Doe
OR
Multiple emails, with one file each, with one tab each to John Doe.

But what I'd LIKE to do is send:
ONE email, with MULTIPLE files, with ONE tab each to John Doe.

I currently use:

ActiveWorkbook.SendMail Recipients:=RecipName, Subject:=Right(ActiveWorkbook.FullName, 22)

Is there a way to just attach the file first, without sending it, so that I can attach more before i send at the end? Here's the full, messy code (this version sends multiple emails, with one file each, with one tab each).

Sub SaveTabs()
Dim Mail As String
Mail = ""
Dim Tabs As String
Dim Found As String

Application.ScreenUpdating = False
Response = MsgBox("Do you wish to automatically e-mail the results to the recipients?", vbYesNo)
If Response = 6 Then Mail = "Yes"

Range("a2").Activate
Selection.End(xlDown).Select
bottom = Selection.Row
Range("a3").Activate
 
For counter1 = 3 To bottom
NamePoint = ActiveCell.Address
RecipName = ActiveCell.Value

Selection.End(xlToRight).Select
Rightend = Selection.Column
Range("b" & counter1).Activate
Tabs = ActiveCell.Value
TabPoint = ActiveCell.Address

Workbooks.Open Filename:="z:\OPTIMIZER\OPTIMIZER_EMAIL_TEMPLATES\Staging.xls"
Workbooks.Open Filename:="z:\OPTIMIZER\OPTIMIZER_EMAIL_TEMPLATES\Optimizer_REG01.xls"

For counter2 = 2 To Rightend
Workbooks("Optimizer_REG01.xls").Activate
Sheets("Begin").Activate

For counter3 = 1 To 5000
    If ActiveSheet.Name = Tabs Then
            ActiveSheet.Copy before:=Workbooks("Staging.xls").Sheets("Start")
            Range("a1:iv1000").Copy
            Range("A1").PasteSpecial xlPasteValues
            Range("a1").Select
            Found = True
            counter3 = 5000
            FDate = Left(Date, 2) & Right(Date, 2)
            Workbooks("Staging.xls").Activate
            Application.DisplayAlerts = False
            Sheets("Start").Delete
            If Right(ActiveSheet.Name, 3) = "MTH" Then
                ActiveWorkbook.SaveAs Filename:="c:\My Documents\Optimizer_" & ActiveSheet.Name & ".xls"
            Else
                ActiveWorkbook.SaveAs Filename:="c:\My Documents\Optimizer_" & ActiveSheet.Name & ".xls"
End If
If Mail = "Yes" Then ActiveWorkbook.SendMail Recipients:=RecipName, Subject:=Right(ActiveWorkbook.FullName, 22)
    
Else
End If
Application.DisplayAlerts = True
ActiveWorkbook.Close
Workbooks.Open Filename:="z:\OPTIMIZER\OPTIMIZER_EMAIL_TEMPLATES\Staging.xls"
        Else
            Found = False
            If ActiveSheet.Next.Name = "End" Then
                MsgBox ("Position '" & Tabs & "' is listed under " & RecipName & " but could not be found!")
                MsgBox ("The macro will end now.  Please ensure the position is valid and re-run.")
                Workbooks("OPTIMIZER Delivery REG01.xls").Activate
                Exit Sub
            Else
                ActiveSheet.Next.Select
            End If
    End If
Next counter3

Workbooks("OPTIMIZER Delivery REG01.xls").Activate
Range(TabPoint).Activate
ActiveCell.Offset(0, 1).Activate
TabPoint = ActiveCell.Address
Tabs = ActiveCell.Value
Next counter2

Workbooks("OPTIMIZER Delivery REG01.xls").Activate
Range(NamePoint).Activate
ActiveCell.Offset(1, 0).Activate
Next counter1
Workbooks("Staging.xls").Activate
ActiveWorkbook.Close
Workbooks("Optimizer_REG01.xls").Activate
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

 

[MarkAndrews]

Maybe you could adapt this?

Sub Mail()

ActiveWorkbook.Save
'You must add a reference to the Microsoft outlook Library
     Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim Mail As Variant

Mail = MsgBox("Click OK to automatically email this workbook", vbInformation + vbOKCancel)
If Mail = vbCancel Then
Exit Sub
End If


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    strbody = Application.InputBox("Would you like to enter a message as part of the email?", "Email message", Type:=2)
 
    With OutMail
        .To = "Enter Recipients"
        .CC = "Enter Recipients"
        .BCC = "Enter Recipients"
        .Subject = "Uploads Spreadsheet - " & Date
        .Body = strbody
        .Attachments.Add ActiveWorkbook.FullName
        On Error Resume Next
        .Send   'or use .Display
        If Err > 0 Then MsgBox "You clicked 'No' - Therefore the email was not sent"
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    MsgBox "Providing you clicked Yes, this email will appear in your Sent Box in Outlook"
    ActiveWorkbook.Save
    ActiveWorkbook.Close
 
End Sub

 

[tvoltagg]

Appreciate the idea, but is there another way?

 

[MarkAndrews]

Maybe this page can help

http://www.rondebruin.nl/mail/folder3/message.htm

 

[tvoltagg]

Got it, it worked. Thanks so much for your help.

One other question though..

Right now, I have to cycle through a whole bunch of tabs to find the tab i want to email to each person (counter3 in the code above). Is there a way to just "find" the tab in question without having to cycle through all the tabs?

 

[nagu_flex]

--------------------------------------------------------------------------------

Maybe this page can help

http://www.rondebruin.nl/mail/folder3/message.htm


When i using the same. Everytime my outlook was asking

" Program is trying to automatically send e-mail on your behalf Do you want to allow thi?"

Everytime i have to response the same.

Could you plz help me to avoid the same.

Regds,
Nagu