Email workbook using Outlook

Trevor3007

Trevor3007

Well-known Member
Joined
Jan 26, 2017
Messages
675
Office Version
  1. 365
Platform
  1. Windows
hi,

Doe anyone have the solution to my issue?

I would like to email the applicable workbook to out look. It will always be ( for the foreseeable future ATM) to the same recipients.

1 x to

2 x CC

however, I need the subject line to contain the WC (IE 03/09/18) which will change weekly & always the 1st Monday of the applicable week.

And the body of the email would say "This is 1 of 5" or 2 of 5 etc ( this would depend of it was a 4/5 week) . It would also display the 1st Friday of the next month (IE 7/9/18)

I don know if it would design something in Excel to then transpose in outlook.... Anyhoo , I do hope some canny & knowledgeable person is up the challenge & can sort this for me?

KR
Trevor3007
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
.
I believe this will accomplish your goal :

Code: 
Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("I2:I100")) = 0 Then
        MsgBox "To send email, please enter an X in Column I.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "I").Value) <> "" Then
        
        
    With Application.ActiveSheet
        MailAttachments = Cells(cell.Row, "H").Value
    End With
        
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Greetings :" & vbNewLine & vbNewLine & _
                        "This is :  " & Cells(cell.Row, "F") & "." & vbNewLine & vbNewLine & _
                        "Next Friday's date is :  " & Cells(cell.Row, "G") & vbNewLine & _
                        "Please let me know if you have any questions." & vbNewLine & vbNewLine & _
                        "Thanks"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add MailAttachments
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell




cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub


Sub ClrMailToSend()
    Sheets("Sheet1").Range("I2:I100").Value = ""
End Sub


Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)


'Set the display properties - these are optional
'All the settings must be applied before the .Show command


'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False


'Set the title of of the DialogBox
dialogBox.Title = "Select a file"


'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub

Download workbook here : https://www.amazon.com/clouddrive/share/Znf39WApzODiJLBwEwLjYKf14vj6drrewwk3Ukpivcm
 
Upvote 0
.
Here is an edited version that may provide less user error :

Code: 
Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("I2:I100")) = 0 Then
        MsgBox "To send email, please enter an X in Column I.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "I").Value) <> "" Then
        
        
    With Application.ActiveSheet
        MailAttachments = Cells(cell.Row, "H").Value
    End With
        
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Greetings :" & vbNewLine & vbNewLine & _
                        "This is :  " & Cells(cell.Row, "F") & "." & vbNewLine & vbNewLine & _
                        "Next Friday's date is :  " & Cells(cell.Row, "G") & vbNewLine & _
                        "Please let me know if you have any questions." & vbNewLine & vbNewLine & _
                        "Thanks"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add MailAttachments
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell




cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub


Sub ClrMailToSend()
    Sheets("Sheet1").Range("I2:I100").Value = ""
End Sub


Sub MsgYesNoSub() [COLOR=#ff0000][B]'<<------------- ADDED THIS MACRO[/B][/COLOR]
Dim Ans As Integer


    Ans = MsgBox("Have you selected a cell in Column H ?", vbYesNo + vbDefaultButton1, "Yes/No")
   
    If Ans = vbYes Then
        GetFilePath
    Else
        Exit Sub
    End If


End Sub


Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)




'Set the display properties - these are optional
'All the settings must be applied before the .Show command


'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False


'Set the title of of the DialogBox
dialogBox.Title = "Select a file"


'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub
 
Last edited:
Upvote 0
Logit said:
.
Here is an edited version that may provide less user error :

Code: 
Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("I2:I100")) = 0 Then
        MsgBox "To send email, please enter an X in Column I.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "I").Value) <> "" Then
        
        
    With Application.ActiveSheet
        MailAttachments = Cells(cell.Row, "H").Value
    End With
        
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Greetings :" & vbNewLine & vbNewLine & _
                        "This is :  " & Cells(cell.Row, "F") & "." & vbNewLine & vbNewLine & _
                        "Next Friday's date is :  " & Cells(cell.Row, "G") & vbNewLine & _
                        "Please let me know if you have any questions." & vbNewLine & vbNewLine & _
                        "Thanks"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add MailAttachments
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell




cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub


Sub ClrMailToSend()
    Sheets("Sheet1").Range("I2:I100").Value = ""
End Sub


Sub MsgYesNoSub() [COLOR=#ff0000][B]'<<------------- ADDED THIS MACRO[/B][/COLOR]
Dim Ans As Integer


    Ans = MsgBox("Have you selected a cell in Column H ?", vbYesNo + vbDefaultButton1, "Yes/No")
   
    If Ans = vbYes Then
        GetFilePath
    Else
        Exit Sub
    End If


End Sub


Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)




'Set the display properties - these are optional
'All the settings must be applied before the .Show command


'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False


'Set the title of of the DialogBox
dialogBox.Title = "Select a file"


'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub
Click to expand...

good morning logit,

thank you for your help..very much appreciated.

The filename will change weekly , would this be an issue as I presume that the filename would have to be always be the same?

KR
Trevor3007
 
Upvote 0
Logit said:
.
Here is an edited version that may provide less user error :

Code: 
Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("I2:I100")) = 0 Then
        MsgBox "To send email, please enter an X in Column I.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "I").Value) <> "" Then
        
        
    With Application.ActiveSheet
        MailAttachments = Cells(cell.Row, "H").Value
    End With
        
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Greetings :" & vbNewLine & vbNewLine & _
                        "This is :  " & Cells(cell.Row, "F") & "." & vbNewLine & vbNewLine & _
                        "Next Friday's date is :  " & Cells(cell.Row, "G") & vbNewLine & _
                        "Please let me know if you have any questions." & vbNewLine & vbNewLine & _
                        "Thanks"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add MailAttachments
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell




cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub


Sub ClrMailToSend()
    Sheets("Sheet1").Range("I2:I100").Value = ""
End Sub


Sub MsgYesNoSub() [COLOR=#ff0000][B]'<<------------- ADDED THIS MACRO[/B][/COLOR]
Dim Ans As Integer


    Ans = MsgBox("Have you selected a cell in Column H ?", vbYesNo + vbDefaultButton1, "Yes/No")
   
    If Ans = vbYes Then
        GetFilePath
    Else
        Exit Sub
    End If


End Sub


Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)




'Set the display properties - these are optional
'All the settings must be applied before the .Show command


'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False


'Set the title of of the DialogBox
dialogBox.Title = "Select a file"


'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub
Click to expand...

Hi logit,

Think I'd lost the plot re my previous.

Having now tested I now get it:]

However this is needs to be in the body of the email (this is deemed by recipient) :


Please Delete Any Previous Emails Related To This Period


Number 1 of 4 timesheets covering the period WC 02/07/18WE 02/9/18 and to be paid 5/10/18.


Good morning,

Please find attached applicabletimesheet/expense's/receipts for WC :



Number 1 of 4 timesheets to be paid 5/10/18


KR
TMcL




Would this be possible to sort?

Kind regards
Trevor
 
Upvote 0
.
Let's see if this meets your needs ...

I added another macro in the Sheet Level module. It allows you to double-click the cell in Column I which will place an X in that cell. You can also double-click the same cell again to erase the X
in case the wrong row was selected.

Code: 
Option Explicit


Private Sub Worksheet_BeforeDoubleClick( _
            ByVal Target As Range, Cancel As Boolean)
    Dim rInt As Range
    Dim rCell As Range


    Set rInt = Intersect(Target, Range("I:I"))
    If Not rInt Is Nothing Then
        For Each rCell In rInt
            If rCell.Value = "X" Then
                rCell.Value = ""
            Else
                rCell.Value = "X"
                rCell.HorizontalAlignment = xlCenter
            End If
        Next
    End If
    Set rInt = Nothing
    Set rCell = Nothing
    Cancel = True
End Sub

Here is the edited version of the email macro with (hopefully) the corrected email message layout :

Code: 
Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("I2:I100")) = 0 Then
        MsgBox "To send email, please enter an X in Column I.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "I").Value) <> "" Then
        
        
    With Application.ActiveSheet
        MailAttachments = Cells(cell.Row, "H").Value
    End With
        
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Please Delete Any Previous Emails Related To This Period" & vbNewLine & vbNewLine & _
                        "Number " & Cells(cell.Row, "F") & " timesheets covering the period WC " & Cells(cell.Row, "A") & " WE " & Cells(cell.Row, "G") & " and to be paid " & Cells(cell.Row, "G") + 90 & " ." & vbNewLine & vbNewLine & _
                        "Good Morning, " & vbNewLine & vbNewLine & _
                        "Please find attached applicable time sheet / expense's / receipts for WC: " & Cells(cell.Row, "A") & vbNewLine & vbNewLine & _
                        "Number : " & Cells(cell.Row, "F") & " timesheets to be paid " & Cells(cell.Row, "G") + 90 & vbNewLine & vbNewLine & _
                        "KR" & vbNewLine & vbNewLine & _
                        "TMcL"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add MailAttachments
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell




cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub


Sub ClrMailToSend()
    Sheets("Sheet1").Range("I2:I100").Value = ""
End Sub


Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)


'Set the display properties - these are optional
'All the settings must be applied before the .Show command


'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False


'Set the title of of the DialogBox
dialogBox.Title = "Select a file"


'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub


Download link: https://www.amazon.com/clouddrive/share/rRGXU5gLDRX7xoNh3rLpXG61HU3jsnUVjHl0hQJqUYd
 
Last edited:
Upvote 0
Logit said:
.
I believe this will accomplish your goal :

Code: 
Option Explicit


Sub PC_Email()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MailAttachments As String
    Dim cell As Variant '                             Not previously DIM'd
    
    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
  
   On Error GoTo cleanup
    If WorksheetFunction.CountA(Range("I2:I100")) = 0 Then
        MsgBox "To send email, please enter an X in Column I.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "I").Value) <> "" Then
        
        
    With Application.ActiveSheet
        MailAttachments = Cells(cell.Row, "H").Value
    End With
        
    
    Set OutMail = OutApp.CreateItem(0)
        
            On Error Resume Next
                              
            With OutMail
            
              strbody = "Greetings :" & vbNewLine & vbNewLine & _
                        "This is :  " & Cells(cell.Row, "F") & "." & vbNewLine & vbNewLine & _
                        "Next Friday's date is :  " & Cells(cell.Row, "G") & vbNewLine & _
                        "Please let me know if you have any questions." & vbNewLine & vbNewLine & _
                        "Thanks"
              
                .To = Cells(cell.Row, "C").Value
                .CC = Cells(cell.Row, "D").Value
                .BCC = Cells(cell.Row, "E").Value
                .Subject = Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add MailAttachments
                
                .Display  'Or use .Send
                  
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell




cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub


Sub ClrMailToSend()
    Sheets("Sheet1").Range("I2:I100").Value = ""
End Sub


Sub GetFilePath()
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)


'Set the display properties - these are optional
'All the settings must be applied before the .Show command


'Do not allow multiple files to be selected
dialogBox.AllowMultiSelect = False


'Set the title of of the DialogBox
dialogBox.Title = "Select a file"


'Show the dialog box and output full file path and file name
If dialogBox.Show = -1 Then
   ActiveCell.Value = dialogBox.SelectedItems(1)
End If
End Sub

Download workbook here : https://www.amazon.com/clouddrive/share/Znf39WApzODiJLBwEwLjYKf14vj6drrewwk3Ukpivcm
Click to expand...

good evening logit,

hope your day went well?

I copied your attachment into the a workbook that I am using..however when I run the vb it comes back via debug:

run-time error 9

and yellow highlights

Sheets("Sheet8").Select ' Edit as required

(your original displays Sheets("Sheet1")


there are several sheets in my work book
fOxjlQbIarUYllt4ZpZQMv6Pef5UK3iEQlUKTkbv0MI


https://www.amazon.co.uk/clouddrive/share/fOxjlQbIarUYllt4ZpZQMv6Pef5UK3iEQlUKTkbv0MI

please see link above.

KR
Trevor3007
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Sort emails in Outlook 365 folder, and loop through them opening the oldest first
Replies
7
Views
2K
John_w
J
Trevor3007
  • Question Question
send email to 2 different email accounts
Replies
0
Views
702
Trevor3007
Trevor3007
lost_in_the_sauce
  • Solved
Add signature to VBA for auto email tabs
Replies
4
Views
981
lost_in_the_sauce
lost_in_the_sauce
willow1985
  • Solved
VBA Compile error - Trying to send an email using VBA/Excel
Replies
6
Views
1K
gorgkhan
G
sanantonio
  • Question Question
Worksheet > PDF > Auto Email - Code is throwing new error
Replies
1
Views
741
sanantonio
sanantonio

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top