Email workbook using Outlook

[Trevor3007]

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

 

[Trevor3007]

.
Based on the image you provided, you should change the code to read :

Sheets("Sheet1 (2)").Select

The name of that sheet is rather convoluted. If you go to the PROPERTIES window in the VBE (where you took the image shot), you can change the sheet name there.

https://www.amazon.com/clouddrive/share/lWgy5FPn8uOrLfvmfP9lstFtjLXQKab6FD4nFV4twSm

Morning Logit,

thank you for your help. Changed the applicable & no errors :]

But when I click the 'S' button, it goes through the motions but outlook does not open?

Hope you can sort.

Code below:-

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 (2)").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 Disregard Any Previous Timesheets Regarding This WC :" & vbNewLine & vbNewLine & _
                        "This is :  " & Cells(cell.Row, "F") & "." & vbNewLine & vbNewLine & _
                        "Payment Due :  " & Cells(cell.Row, "B") & vbNewLine & _
                        "Please Contact Me If There Any Issues That Would Otherwise Delay Payment." & vbNewLine & vbNewLine & _
                        "Kind Regards" & vbNewLine & vbNewLine & _
                        "Trevor"
                        
              
                .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 = ""

 

[Logit]

.
When you click the SEND button, the email should be created and display on screen for your review. You can then either edit the email or send as is.
If the email is not showing, I'm not certain why that is.

The macro code line " .DISPLAY " instructs the email to be viewed and requires you to manually click the SEND button on the email itself before it will process.


If however, you mean that the email program OUTLOOK itself is not activated prior to seeing the email for review, you can add the line " SHELL("Outlook") to the
beginning of the macro. This line will start the OUTLOOK program. Here is a sample of where to insert that command line :

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
    
[COLOR=#ff0000][B]    Shell ("OUTLOOK")                  '<<<<--------- ADD THIS LINE[/B][/COLOR]


    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

Do either of these answer your question ?

 

[Trevor3007]

Hi logit,

thank you very much for all you help. I decided to go with your original rather. Just a couple of wee things:-

.Subject = Cells(cell.Row, "A").Value

I need to add WC in front , so it the subject would read:
WC 3/9/18

and I need to send several attachments , can you sort please.

Think that would be the whole 9 yards.

Many thanks in advance & very much appreciated to.
KR
Trevor

 

[Trevor3007]

.
When you click the SEND button, the email should be created and display on screen for your review. You can then either edit the email or send as is.
If the email is not showing, I'm not certain why that is.

The macro code line " .DISPLAY " instructs the email to be viewed and requires you to manually click the SEND button on the email itself before it will process.


If however, you mean that the email program OUTLOOK itself is not activated prior to seeing the email for review, you can add the line " SHELL("Outlook") to the
beginning of the macro. This line will start the OUTLOOK program. Here is a sample of where to insert that command line :

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
    
[COLOR=#ff0000][B]    Shell ("OUTLOOK")                  '<<<<--------- ADD THIS LINE[/B][/COLOR]


    Sheets("Sheet1").Select '                         Edit as required
    Range("A1").Select
    
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

Do either of these answer your question ?

just as you thought it was safe to come out of the VB...…. please see vid via link below:-

[video]https://www.amazon.co.uk/clouddrive/share/x3WoyR4VGYRpP6ElZLbN6J3uNFVZEHclSR4EI97yGEz[/video]

KR
Trevor

 

[Logit]

.
Here is the updated macro and workbook :

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("K2:K100")) = 0 Then
        MsgBox "To send email, please enter an X in Column K.", vbCritical, "Missing Entry"
        Exit Sub
    End If
    For Each cell In Columns("C").Cells
        If cell.Value Like "?*@?*.?*" And _
        LCase(Cells(cell.Row, "K").Value) <> "" Then
    
    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 = "WC " & Cells(cell.Row, "A").Value
                .Body = strbody
               
                '.Attachments.Add Application.ActiveWorkbook.FullName
                .Attachments.Add ActiveSheet.Cells(cell.Row, "H").Value
                .Attachments.Add ActiveSheet.Cells(cell.Row, "I").Value
                .Attachments.Add ActiveSheet.Cells(cell.Row, "J").Value
                
                .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("K2:K100").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 = True


'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 : https://www.amazon.com/clouddrive/share/06nAj9iq2caB13ob9j7dtcOAmsfrJWRLDek0j9qMToG

 

[Logit]

.
Change the GetFilePath macro to this :

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 = True


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


[COLOR=#ff0000]'Set the initial path to :[/COLOR]
[COLOR=#ff0000] dialogBox.InitialFileName = "C:\Users\work3\OneDrive\timesheets as from May2018\"[/COLOR]


'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

 

[Trevor3007]

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

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

please see link above.

KR
Trevor3007

Hi logit,

Thank you for all your efforts.

I thought it was an issue when I tweaked your VBA...issue being 'Outlook client' would not open when I invoked/stared he \\vba.
So I went back to brass tacks and ran your original without any teaks & Outlook still does not open???
I reboot (thinking this would sort) and again opened/start your original .. bit still does not work :{

Am totally ??????????? as to why , as I can lick on outlook & all is good , so would suggest its not the client but something in the VB?
….but heyho , what do I know.

I totally understand if you what to give up the ghost with this & I am still very very grateful for all your input/help etc.

KR
Trevor3007

 

[Logit]

.
Strange .. the SHELL command should work in all situations.

You could try the code from Ron de Bruin's website. He is the VBA Email Guru ...

https://www.rondebruin.nl/win/s1/outlook/openclose.htm

 

[Trevor3007]

.
Strange .. the SHELL command should work in all situations.

You could try the code from Ron de Bruin's website. He is the VBA Email Guru ...

https://www.rondebruin.nl/win/s1/outlook/openclose.htm

Ho logit,

thanks for your assistance.

Checked the site & even using his 'test' code, outlook still does not open...…………..oooh bother just as I thought I was about to cross the finishing line too :{

MTA
Trevor

 

[Logit]

.
This is a direct way of opening Outlook, using the full path to the program.

If you are unable to open Outlook using this macro, there is something wrong with your computer ... or O/S ... or Outlook is not installed on your compter:

Option Explicit


Sub OutLookOpen()
    Dim x As Variant
    Dim Path As String


    ' Set the Path variable equal to the path of your program's installation
    Path = "C:\Program Files (x86)\Microsoft Office\Office12\Outlook.exe" [COLOR=#ff0000][B]'<---- change the path in this line to match the location of Outlook on your computer[/B][/COLOR]


    x = Shell(Path, vbNormalFocus)
End Sub