created email in VB, user clicks on cancel.

[SlinkyWheels]

Hi

I have some vb code that creates an email with an attachment.

How do I identify whether the user has clicked on "Send" or on the X to close the email down without sending it?

 

[mrbeanyuk]

Can you post the coding up? You can set it so the email sends automatically unless you want the choice?

The coding I use puts a timer that says the email will send in 5 seconds. If the user wants to cancel they can otherwise it sends on its own

 

[SlinkyWheels]

Whoops!!! Sorry.

If it sends I need it to do one thing, if they click on cancel, I need it to do another.

Private Sub cmdYes_Click()
On Error GoTo ErrorHandler

Dim FileExtStr As String
Dim FileFormatNum As Long
'Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim MsgPart1, MsgPart2, MsgPart3 As String

Application.ScreenUpdating = False

Company = Application.OrganizationName

MsgPart1 = vbCrLf & "Please find attached the latest copy of the Appendix B Data." & vbCrLf & vbCrLf
MsgPart2 = "Kind regards," & vbCrLf & vbCrLf
MsgPart3 = Company

MsgBody = MsgPart1 & MsgPart2 & MsgPart3

'copy the sheet to a new workbook and delete all previously sent data

ActiveWorkbook.Unprotect Password:="PassApp"

Sheets("AppBDataSheet").Visible = True
Sheets("AppBDataSheet").Unprotect "PassAppB"

Sheets("AppBDataSheet").Select

            With Sheets("AppBDataSheet")
            .Range("A1").CurrentRegion.Sort key1:=.Range("AH2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
            End With

ActiveSheet.Copy
Set Destwb = ActiveWorkbook

            Range("AH2").Select
            
Step1:
            Do Until ActiveCell.Value = Blank
                Set F = ActiveCell.Find("Yes", LookAt:=xlPart, LookIn:=xlValues)
                If F = "Yes" Then
                ActiveCell.EntireRow.Delete
                GoTo Step1
                End If
                ActiveCell.Offset(1, 0).Select
            Loop
            
            Range("A1").Select

'Excel Version??

With Destwb
FileExtStr = ".xls": FileFormatNum = -4143
End With

'Save new workbook, create and send email, delete this new workbook
TempFilePath = Environ$("temp") & "\"
TempFileName = Company & " - Appendix B Data"

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

With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    On Error Resume Next
    With OutMail
        .to = "Legal.Panel@southwestrda.org.uk"
        .Subject = TempFileName
        .Body = MsgBody
        .Attachments.Add Destwb.FullName
        .Display
        End With
    On Error GoTo 0
    .Close SaveChanges:=False
End With

'Delete the new worksheet
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

'add YES to Column AH for all emailed info
LstRw = Cells(Rows.Count, "A").End(xlUp).Row

Range("AH2").Select

'Do Until ActiveCell.Row > LstRw + 1
Do Until ActiveCell.Row > LstRw

    If ActiveCell.Value = "Yes" Then
    ActiveCell.Offset(1, 0).Select
    End If
    If ActiveCell.Value = Blank Then
    ActiveCell.Value = "Yes"
    ActiveCell.Offset(1, 0).Select
    End If
Loop

Sheets("AppBDataSheet").Protect "PassAppB"
Sheets("AppBDataSheet").Visible = False
ActiveWorkbook.Protect Password:="PassApp"
Application.ScreenUpdating = True
Sheets("Front Screen").Select
Unload Me
UFmainmenu.Show
ErrorHandler:
End Sub

 

[Kevlarhead]

Replace

With Destwb 
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 
    On Error Resume Next 
    With OutMail 
        .to = "Legal.Panel@southwestrda.org.uk" 
        .Subject = TempFileName 
        .Body = MsgBody 
        .Attachments.Add Destwb.FullName 
        .Display 
        End With 
    On Error GoTo 0 
    .Close SaveChanges:=False 
End With

with

Dim UserResponse As Integer

UserResponse = MsgBox ("Are you sure you want to send this?", vbYesNo)

If UserResponse = vbYes Then

With Destwb 
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 
    On Error Resume Next 
    With OutMail 
        .to = "Legal.Panel@southwestrda.org.uk" 
        .Subject = TempFileName 
        .Body = MsgBody 
        .Attachments.Add Destwb.FullName 
        .Send
        End With 
    On Error GoTo 0 
    .Close SaveChanges:=False 
End With 


Else

{Do something else}

End if

 

[SlinkyWheels]

That kind of works (so thankyou for that) but it now brings up a box telling me that a programme is trying to access Outlook.

Is there any way around this? I did not get this message when sending the email in my original code

 

[RichardU]

Try this

Private Sub cmdYes_Click() 
On Error GoTo ErrorHandler 

Dim FileExtStr As String 
Dim FileFormatNum As Long 
'Dim Sourcewb As Workbook 
Dim Destwb As Workbook 
Dim TempFilePath As String 
Dim TempFileName As String 
Dim OutApp As Object 
Dim OutMail As Object 
Dim MsgPart1, MsgPart2, MsgPart3 As String 

Application.ScreenUpdating = False 

Company = Application.OrganizationName 

MsgPart1 = vbCrLf & "Please find attached the latest copy of the Appendix B Data." & vbCrLf & vbCrLf 
MsgPart2 = "Kind regards," & vbCrLf & vbCrLf 
MsgPart3 = Company 

MsgBody = MsgPart1 & MsgPart2 & MsgPart3 

'copy the sheet to a new workbook and delete all previously sent data 

ActiveWorkbook.Unprotect Password:="PassApp" 

Sheets("AppBDataSheet").Visible = True 
Sheets("AppBDataSheet").Unprotect "PassAppB" 

Sheets("AppBDataSheet").Select 

            With Sheets("AppBDataSheet") 
            .Range("A1").CurrentRegion.Sort key1:=.Range("AH2"), Order1:=xlAscending, _ 
            Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 
            End With 

ActiveSheet.Copy 
Set Destwb = ActiveWorkbook 

            Range("AH2").Select 
            
Step1: 
            Do Until ActiveCell.Value = Blank 
                Set F = ActiveCell.Find("Yes", LookAt:=xlPart, LookIn:=xlValues) 
                If F = "Yes" Then 
                ActiveCell.EntireRow.Delete 
                GoTo Step1 
                End If 
                ActiveCell.Offset(1, 0).Select 
            Loop 
            
            Range("A1").Select 

'Excel Version?? 

With Destwb 
FileExtStr = ".xls": FileFormatNum = -4143 
End With 

'Save new workbook, create and send email, delete this new workbook 
TempFilePath = Environ$("temp") & "\" 
TempFileName = Company & " - Appendix B Data" 

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

Dim UserResponse As Integer 

UserResponse = MsgBox ("Are you sure you want to send this?", vbYesNo) 

If Not UserResponse = vbYes Then Exit Sub
Else

With Destwb 
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 
    On Error Resume Next 
    With OutMail 
        .to = "Legal.Panel@southwestrda.org.uk" 
        .Subject = TempFileName 
        .Body = MsgBody 
        .Attachments.Add Destwb.FullName 
        .Display
        End With 
    On Error GoTo 0 
    .Close SaveChanges:=False 
End With 
SendKeys "%{s}", True

'Delete the new worksheet 
Kill TempFilePath & TempFileName & FileExtStr 

Set OutMail = Nothing 
Set OutApp = Nothing 

'add YES to Column AH for all emailed info 
LstRw = Cells(Rows.Count, "A").End(xlUp).Row 

Range("AH2").Select 

'Do Until ActiveCell.Row > LstRw + 1 
Do Until ActiveCell.Row > LstRw 

    If ActiveCell.Value = "Yes" Then 
    ActiveCell.Offset(1, 0).Select 
    End If 
    If ActiveCell.Value = Blank Then 
    ActiveCell.Value = "Yes" 
    ActiveCell.Offset(1, 0).Select 
    End If 
Loop 

Sheets("AppBDataSheet").Protect "PassAppB" 
Sheets("AppBDataSheet").Visible = False 
ActiveWorkbook.Protect Password:="PassApp" 
Application.ScreenUpdating = True 
Sheets("Front Screen").Select 
Unload Me 
UFmainmenu.Show 
ErrorHandler: 
End Sub

 

[SlinkyWheels]

Legendary!!! Thankyou for all the help.