VBA - Saving an email only after 'Send' is pushed?

[mv2005]

I have a spreadsheet that automatically creates an email (based on code from rondebruin.com and some manipulation from a consultant) and initially would just save a copy of the message on our network (for records purposes) as well as sending it.

However it occured to me after that there will be times when attachments are required and as such for archiving purposes it really needs any attachments to also be saved as part of the email. What I believe to be the relevant code is shown below:

With OutMail
.To = TextBox6.Value
.CC = ""
.BCC = ""
.subject = "MRWA response to your inquiry on " & ComboBox9.Value
.body = strbody
.Display 'or use .Send
.SaveAs "\\Dacsrv02\rtddata\Advice\Tech Queries\TRIM Emails\" & emailname
End With
On Error GoTo 0

The thing is it is storing the email at the same time it opens it for display. As such any attachments would be made post save. How would I go about getting it to wait until after attachments have been made (presumably once it detects the 'Send' button has been pushed on the email)?

Thanks
Mike

 

[GTO]

Greetings Mike,

Presuming this is in Outlook, while I'm pretty sure a class module is required, I think you can use the 'ItemSend' event.

Something like:

Private Sub objOutlook_ItemSend(ByVal Item As Object, Cancel As Boolean)
    '... SaveAs and/or other code...
End Sub

You can find some info on the event in Outlook's vba helpfile.

Hope this helps,

Mark

 

[mv2005]

Hi Mark,

Whilst the email program is Outlook, the actual macro is within Excel. What happens is you click on a CommandButton (within the Excel spreadsheet) titled Log Response. This then automatically opens Outlook and cuts and pastes a range of information contained within cells, drop downs and text boxes in Excel. As such the code I showed previously was part of the Excel VBA. What currently happens is that a copy of the email is being saved in the appropriate network folder at the same time as it opens the email for the logger to see. It is only once the email is open that the logger can attach any files but by this stage it is too late because the copy has already been saved.

Can the code you presented below be used within Excel or is it purely Outlook based - as I'm trying to keep everything contained within Excel?

Thanks
Mike

 

[GTO]

Hi Mark,

...This then automatically opens Outlook...

Okay, then I presume you are using CreateObject or GetObject someplace to Get or Create an instance of Outlook. Am I correct thus far?

... and cuts and pastes a range of information contained within cells, drop downs and text boxes in Excel....

Just because I can occassionally be a bit thick-headed, you mean you are copying stuff from the workbook and pasting it into the .Body of the MailItem, right?

...What currently happens is that a copy of the email is being saved in the appropriate network folder at the same time as it opens the email for the logger to see. It is only once the email is open that the logger can attach any files but by this stage it is too late because the copy has already been saved.

Can the code you presented below be used within Excel or is it purely Outlook based - as I'm trying to keep everything contained within Excel?

Presuming you are using GetObject or CreateObject, then I think it would be doable. I would imagine there might have to be some handling written in to compensate in the case that the user decides to cancel and doesn't send the created MailItem "OutMail"

Mark

 

[mv2005]

Sorry Mark,

I should have pasted all code relevant to Outlook. Here is more of the code. Note the back half relates to opening another spreadsheet and doing lookup type procedures (based on original info in the first spreadsheet) and has nothing to do with the Outlook part, hence I have omitted it:

Sub Email_Response()

Dim OutApp As Object
Dim OutMail As Object
Dim copymail As NewFile
Dim strbody As String
Dim Staff As String
Dim Who As String
Dim What As String
Dim How_Long As String
Dim emailname As String
Dim emaildate, newdate As String
Dim Fortnight As Date
Dim Name As Integer
Dim Criteria1 As Integer
Dim Criteria2 As Integer
Dim Criteria3 As Integer
Dim Criteria5 As Integer
Dim Criteria6 As Integer
Dim Criteria7 As Integer


Sheets("Technical Inquiry Form").Range("c30").Select
ActiveCell.FormulaR1C1 = "=NOW()"
Sheets("Technical Inquiry Form").Range("c30").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Technical Inquiry Form").Activate

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

If OptionButton1.Value = True Then
strbody = "Attention: " & ComboBox6.Text & vbNewLine & vbNewLine & _
"On " & Sheets("Technical Inquiry Form").Range("b3").Value & _
" you contacted Main Roads' " & ComboBox2.Value & " with the following inquiry: " & vbNewLine & vbNewLine & _
TextBox3.Value & vbNewLine & vbNewLine & "Main Roads offers the following response: " & vbNewLine & TextBox8.Value & vbNewLine & _
"Thank you for your inquiry." & vbNewLine & vbNewLine & "Regards " & vbNewLine & ComboBox2.Value
ElseIf OptionButton2.Value = True Then
strbody = "Attention: " & ComboBox7.Value & vbNewLine & vbNewLine & _
"On " & Sheets("Technical Inquiry Form").Range("b3").Value & _
" you contacted Main Roads' " & ComboBox2.Value & " with the following inquiry: " & vbNewLine & vbNewLine & _
TextBox3.Value & vbNewLine & vbNewLine & "Main Roads offers the following response: " & vbNewLine & TextBox8.Value & vbNewLine & _
"Thank you for your inquiry." & vbNewLine & vbNewLine & "Regards " & vbNewLine & ComboBox2.Value
ElseIf OptionButton3.Value = True Then
strbody = "Attention: " & ComboBox8.Value & vbNewLine & vbNewLine & _
"On " & Sheets("Technical Inquiry Form").Range("b3").Value & _
" you contacted Main Roads' " & ComboBox2.Value & " with the following inquiry: " & vbNewLine & vbNewLine & _
TextBox3.Value & vbNewLine & vbNewLine & "Main Roads offers the following response: " & vbNewLine & TextBox8.Value & vbNewLine & _
"Thank you for your inquiry." & vbNewLine & vbNewLine & "Regards " & vbNewLine & ComboBox2.Value
ElseIf OptionButton4.Value = True Then
strbody = "Attention: " & TextBox1.Value & vbNewLine & vbNewLine & _
"On " & Sheets("Technical Inquiry Form").Range("b3").Value & _
" you contacted Main Roads' " & ComboBox2.Value & " with the following inquiry: " & vbNewLine & vbNewLine & _
TextBox3.Value & vbNewLine & vbNewLine & "Main Roads offers the following response: " & vbNewLine & TextBox8.Value & vbNewLine & _
"Thank you for your inquiry." & vbNewLine & vbNewLine & "Regards " & vbNewLine & ComboBox2.Value
End If

On Error Resume Next

emaildate = Sheets("Technical Inquiry Form").Range("c30")
newdate = Day(Sheets("Technical Inquiry Form").Range("c30")) & "-" & Month(Sheets("Technical Inquiry Form").Range("c30")) & "-" & Year(Sheets("Technical Inquiry Form").Range("c30"))
emailname = "MRWA response to inquiry on " & ComboBox9.Value & " (Trim file " & Sheets("Technical Inquiry Form").Range("H22") & ") " & newdate & ".msg"
With OutMail
.To = TextBox6.Value
.CC = ""
.BCC = ""
.subject = "MRWA response to your inquiry on " & ComboBox9.Value
.body = strbody
.Display 'or use .Send
.SaveAs "\\Dacsrv02\rtddata\Advice\Tech Queries\TRIM Emails\" & emailname
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

Thus currently the 'saveas' feature occurs just after displaying the email.

Oh in case you haven't already guessed I'm not responsible for about 1/3 to 1/2 of the shown code hence not everything makes full sense to me (hence my reason for bugging you!).

Cheers
Mike

 

[GTO]

Hey Mike,

No problemo, you are certainly not 'bugging' me. I may not get it all, but I forgot to ask a quick question that might come in handy later. What version of Excel and Outlook will this be running on?

For instance, for me I'd be answering: this will be running in Excel2003/Outlook2003 in XP. Compatability w/ Excel/Outlook 2000 would be desirable.

Thanks,

Mark

 

[mv2005]

Sorry Mark, I thought I had posted a reply but I had timed out and it didn't get sent.

We've just rolled out 2007 having been using 2003 for some time. Oh and we are using XP.

Mike

 

[GTO]

Greetings Mike,

Here is a rough draft/example of using the Outlook Event 'ItemSend'.

So as I don't goober up your workbook/project, please make a copy of the workbook, and try it there first.

Now in whatever module you have your EMail_Response() sub, at the top of the module (above any procedures), paste the below:

Option Explicit
Dim cls_OL As New clsOutlook
Public objMail_SentMsg As Object
Public emailname As String

Then for the sub itself, try:

Sub Email_Response()
'// DELETE:  Dim OutApp As Object
Dim OutMail As Object
Dim copymail As NewFile
Dim strbody As String
Dim Staff As String
Dim Who As String
Dim What As String
Dim How_Long As String
Dim emaildate, newdate As String
Dim Fortnight As Date
Dim Name As Integer
Dim Criteria1 As Integer
Dim Criteria2 As Integer
Dim Criteria3 As Integer
Dim Criteria5 As Integer
Dim Criteria6 As Integer
Dim Criteria7 As Integer
 
   '// Rather than...                                                          //
   '// Select C30,...                                                          //
    'Sheets("Technical Inquiry Form").Range("c30").Select
 
   '// ...then set it to NOW(),...                                             //
   'ActiveCell.FormulaR1C1 = "=NOW()"
 
   '// ...then reselect C30 (unnecessary in any event...                       //
   'Sheets("Technical Inquiry Form").Range("c30").Select
 
   '// ... then Copy it...                                                     //
   'Selection.Copy
 
   '// ... then finally put in what we were after (the current date/time)...   //
   'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
   ':=False, Transpose:=False
 
   '// Let's just do this:                                                     //
    Worksheets("Technical Inquiry Form").Range("C30").Value = Now()
 
   '// I don't believe this line is required, as ea Range is qualified.        //
   'Worksheets("Technical Inquiry Form").Activate
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
'    Set OutApp = GetObject(, "Outlook.Application")
    Set cls_OL.obj_OL = CreateObject("Outlook.Application")
 
'    OutApp.Session.Logon
    cls_OL.obj_OL.Session.Logon
 
'    Set OutMail = OutApp.CreateItem(0)
    Set OutMail = cls_OL.obj_OL.CreateItem(0)
    Set objMail_SentMsg = OutMail
 
'    If OptionButton1.Value = True Then
'        '... strBody built here...
'    End If
   '// Example substitute                                                      //
    strbody = "This is just example text, to substitute for the string built " & _
              "from all the text boxes etc..."
 
    On Error Resume Next
 
    emaildate = Sheets("Technical Inquiry Form").Range("c30")
 
    newdate = Day(Sheets("Technical Inquiry Form").Range("c30")) & "-" & _
              Month(Sheets("Technical Inquiry Form").Range("c30")) & "-" & _
              Year(Sheets("Technical Inquiry Form").Range("c30"))
 
    emailname = "MRWA response to inquiry on " & "ComboBox9.Value" & _
                " (Trim file " & _
                Sheets("Technical Inquiry Form").Range("H22") & ") " & _
                newdate & ".msg"
    With OutMail
        .To = TextBox6.Value
        .CC = ""
        .BCC = ""
        .Subject = "MRWA response to your inquiry on " & "ComboBox9.Value"
        .body = strbody
        .Display 'or use .Send
       '// DELETE: .SaveAs "\\Dacsrv02\rtddata\Advice\Tech Queries\" & _
                           "TRIM Emails\" & emailname
       '// moved to the class module.                                      //
    End With
 
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    Set OutMail = Nothing
    'Set OutApp = Nothing
End Sub

Now you need to create a new Class Module. Rename the Class Module: "clsOutlook"

Then paste all the below in the new/blank Class mod:

Option Explicit
Public WithEvents obj_OL As Outlook.Application
 
Private Sub obj_OL_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
   '// For example, change pathway to suit, such as:                           //
   '// "\\Dacsrv02\rtddata\Advice\Tech Queries\TRIM Emails\" & emailname
    objMail_SentMsg.SaveAs ThisWorkbook.Path & _
                           Application.PathSeparator & _
                           emailname
End Sub

Now for the above to run, you will notice that I went to early-binding. That is, I declared obj_OL As Outlook.Application rather than as an Object. To use this, you will need to set a reference to Outlook's library. Under Tools, select References, and find and tick the box for "Microsoft Outlook xx.0 Object Library".


By the way, I am presuming you are using this at work and I am curious if your current code "acts" the same for you as it does on the system I'm on. When running your initial code from a workbook, I noted that if I wasn't already logged onto Outlook, it asks for my password twice. Once when it hits .Logon and again at/about where it hits .Display.

Do you experience this(?) or do you just make sure you are already logged on or ???

Mark

 

[mv2005]

THanks Mark,

I'll have a look at this over the weekend and advise. Yes it's a work spreadsheet and our Outlook automatically fires up when we boot up so I've not experienced the problem you speak of. I'll try it at home and see if I too get what you experienced.

Thanks again for your assistance. I'll let you know how I got on.

Cheers
Mike

 

[GTO]

THanks Mark,

I'll have a look at this over the weekend and advise. Yes it's a work spreadsheet and our Outlook automatically fires up when we boot up so I've not experienced the problem you speak of. I'll try it at home and see if I too get what you experienced.

Thanks again for your assistance. I'll let you know how I got on.

Cheers
Mike

Hey Mike,

I don't often use Class Modules, and what I know about Outlook could fit on the back of a ****tail napkin. That said, I cleaned-up my previous suggestion a bit, and got rid of .Logon and a couple of things.

You may well get better suggestions, but in the mean time, try this one first. In short, rather than later worrying about handling a bad logon attempt, we just insist the user is already in Outlook, which as you stated, is the expected case. If this works, we can worry about if the user cancels the email (instead of hitting the Send button).

Mark

In your created Class Module named "clsOutlook":

Option Explicit
Public WithEvents obj_OL As Outlook.Application
'
Private Sub obj_OL_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
    '// For example, change pathway to suit, such as:                           //
    '// "\\Dacsrv02\rtddata\Advice\TechQueries\TRIM Emails\" & emailname
    OutMail.SaveAs ThisWorkbook.Path & _
                           Application.PathSeparator & _
                           emailname
 
    '// AFTER the event has been called, explicitly release Outlook.        //
    Set obj_OL = Nothing
    Set OutMail = Nothing
End Sub

In the standard module that your already had:

Option Explicit
'// Connect the declared object w/the class module                          //
Dim cls_OL As New clsOutlook
'// Declare the email msg (mail item) and emailname string as Public, so    //
'// that they can be "seen" from any procedures in the class mod.           //
Public OutMail As Outlook.MailItem
Public emailname As String
Sub Email_Response()
Dim strbody As String
Dim emaildate As String
Dim newdate As String
'// You no doubt are using some/all of these for other code not included.   //
'// I simply rem'd them to make the example easier to read.                 //
'Dim copymail As NewFile
'Dim Staff As String
'Dim Who As String
'Dim What As String
'Dim How_Long As String
'Dim Fortnight As Date
'Dim Name As Integer
'Dim Criteria1 As Integer
'Dim Criteria2 As Integer
'Dim Criteria3 As Integer
'Dim Criteria5 As Integer
'Dim Criteria6 As Integer
'Dim Criteria7 As Integer
    '// Switch error handling to in-line for a moment.  This way when we    //
    '// try and GetObject, if Outlook is not already running, an error will //
    '// occur, which we can use to tell us what to do next.                 //
    On Error Resume Next
    '// Rather than Create the object, we'll just GetObject.  While this    //
    '// means the user must be logged on to Outlook, this means we no longer//
    '// have to worry about .Logon or what happens if the user goobers up   //
    '// their password.                                                     //
    Set cls_OL.obj_OL = GetObject(Class:="Outlook.Application")
 
    '// If Outlook was running, we skip by this.                            //
    If Err.Number > 0 Then
        '// If we made it here, Outlook was not running, so we want to make //
        '// a graceful exit...                                              //
        On Error GoTo 0
        Err.Clear
        Set cls_OL.obj_OL = Nothing
        MsgBox "Sorry - Outlook must be running before this program can run." _
               & vbCrLf & _
               "Please logon to Outlook, then (push whatever button " & _
               "starts this).", _
               vbCritical, ""
        Exit Sub
    End If
 
    '// Since we made it past the previous test, Outlook is running, and we //
    '// should reset error handling, as elsewise we may have problems       //
    '// in our code 'masked'.                                               //
    On Error GoTo 0
 
    '// "timestamp" the sheet.                                              //
    ThisWorkbook.Worksheets("Technical Inquiry Form").Range("C30").Value = Now()
 
    '// I don't see why we're disabling events, but killing .ScreenUpdating //
    '// will speed up processing if there's data being written or other     //
    '// visible changes that would normally be painted upon execution.      //
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    '// Create our new mail item                                            //
    Set OutMail = cls_OL.obj_OL.CreateItem(0)
'    If OptionButton1.Value = True Then
'        '... strBody built here...
'    End If
    '// Example substitute                                                      //
    strbody = "This is just example text, to substitute for the string built " & _
              "from all the text boxes etc..."
 
    On Error Resume Next
 
    emaildate = Sheets("Technical Inquiry Form").Range("c30")
 
    newdate = Day(Sheets("Technical Inquiry Form").Range("c30")) & "-" & _
              Month(Sheets("Technical Inquiry Form").Range("c30")) & "-" & _
              Year(Sheets("Technical Inquiry Form").Range("c30"))
 
    emailname = "MRWA response to inquiry on " & "ComboBox9.Value" & _
                " (Trim file " & _
                Sheets("Technical Inquiry Form").Range("H22") & ") " & _
                newdate & ".msg"
    With OutMail
        .To = TextBox6.Value
        .CC = ""
        .BCC = ""
        .Subject = "MRWA response to your inquiry on " & "ComboBox9.Value"
        .body = strbody
        .Display
    End With
 
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub