EXCEL CONNECTED WITH OUTLOOK

[Neil Holden]

Below is the code for a button so when pressed YES it will save and the email
the relevant people to say its been accepted, if NO i need it to go to a
default location and then send an outlook email to say its been refused,

At the moment if i press NO it works fine but if i press yes it will send
both the accepted email and the declined, this is probably something stupid
but please help.


Private Sub CommandButton1_Click()

ActiveWorkbook.Save

Dim Response As String
Dim DefaultFolder As String, DefaultFileName As String
Dim FileToSave
Dim OutApp As Object 'this emails operations manager
Dim OutMail As Object
Dim strbody As String

Response = MsgBox("Are you sure you want to Approve this PIP?", _
vbYesNo + vbInformation + vbDefaultButton2)

If Response = vbYes Then

Range("C13:C75") = Date

Dim lngRow As Long, rngTemp As Range
Dim wbBook As Workbook, wsDest As Worksheet

Set rngTemp = ActiveSheet.Range("A13:Q75")
Set wbBook = Workbooks.Open("C:\Documents and
Settings\neil.holden\Desktop\test2.xls")
Set wsDest = wbBook.Sheets("Sheet1") 'Destination sheet
With rngTemp

lngRow = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1

wsDest.Range("A" & lngRow).Resize(rngTemp.Rows.Count, _
rngTemp.Columns.Count) = rngTemp.Value

End With
wbBook.Close True

DefaultFolder = "M:\Procurement\Approved PIPS"
If Right(DefaultFolder, 1) <> "\" Then
DefaultFolder = DefaultFolder & "\"
End If
DefaultFileName = "Project Brief" & " for " &
Sheets("PIP").Range("A13").Value
If Right(UCase(DefaultFileName), 3) <> "XLS" Then
DefaultFileName = DefaultFileName & " " & _
Format(Date, "dd-mm-yyyy") & ".xls"
End If
FileToSave = Application.GetSaveAsFilename _
(DefaultFolder & DefaultFileName, filefilter:="Excel Files (*.xls)," _
& "*.xls", Title:="Save File As...")
If FileToSave = False Then
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:=FileToSave, _
FileFormat:=ActiveWorkbook.FileFormat
End If
End If

If Response = vbYes Then

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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("a13").Value & " " & "PIP ACCEPTED"

On Error Resume Next
With OutMail
.To = "(e-mail address removed); (e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "PIP Accepted"
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End If

If Response = vbNo Then
DefaultFolder = "M:\Procurement\Declined PIPS"
If Right(DefaultFolder, 1) <> "\" Then
DefaultFolder = DefaultFolder & "\"
End If
DefaultFileName = "Declined PIP" & " for " &
Sheets("PIP").Range("A13").Value
If Right(UCase(DefaultFileName), 3) <> "XLS" Then
DefaultFileName = DefaultFileName & " " & _
Format(Date, "dd-mm-yyyy") & ".xls"
End If
FileToSave = Application.GetSaveAsFilename _
(DefaultFolder & DefaultFileName, filefilter:="Excel Files (*.xls)," _
& "*.xls", Title:="Save File As...")
If FileToSave = False Then
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:=FileToSave, _
FileFormat:=ActiveWorkbook.FileFormat
End If
End If



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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("C10").Value & " " & "PIP DECLINED"

On Error Resume Next
With OutMail
.To = "(e-mail address removed); (e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "PIP Declined"
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Exit Sub




End Sub

 

[OssieMac]

Hello Neil,

If you copy the following code back into your VBA editor so that the
comments show in green it will be easier to find and follow my comments and
you will be able to see why the problem is occurring.

Private Sub CommandButton1_Click()

ActiveWorkbook.Save

Dim Response As String
Dim DefaultFolder As String, DefaultFileName As String
Dim FileToSave
Dim OutApp As Object 'this emails operations manager
Dim OutMail As Object
Dim strbody As String

Response = MsgBox("Are you sure you want to Approve this PIP?", _
vbYesNo + vbInformation + vbDefaultButton2)

'******************************************************
'vbYes does all between asterisk lines
If Response = vbYes Then

Range("C13:C75") = Date

Dim lngRow As Long, rngTemp As Range
Dim wbBook As Workbook, wsDest As Worksheet

Set rngTemp = ActiveSheet.Range("A13:Q75")
Set wbBook = Workbooks.Open("C:\Documents and
Settings\neil.holden\Desktop\test2.xls")
Set wsDest = wbBook.Sheets("Sheet1") 'Destination sheet

With rngTemp
lngRow = wsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1

wsDest.Range("A" & lngRow).Resize(rngTemp.Rows.Count, _
rngTemp.Columns.Count) = rngTemp.Value

End With

wbBook.Close True

DefaultFolder = "M:\Procurement\Approved PIPS"

If Right(DefaultFolder, 1) <> "\" Then
DefaultFolder = DefaultFolder & "\"
End If

DefaultFileName = "Project Brief" & " for " &
Sheets("PIP").Range("A13").Value

If Right(UCase(DefaultFileName), 3) <> "XLS" Then
DefaultFileName = DefaultFileName & " " & _
Format(Date, "dd-mm-yyyy") & ".xls"
End If

FileToSave = Application.GetSaveAsFilename _
(DefaultFolder & DefaultFileName, filefilter:="Excel Files (*.xls)," _
& "*.xls", Title:="Save File As...")

If FileToSave = False Then
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:=FileToSave, _
FileFormat:=ActiveWorkbook.FileFormat
End If

End If
'*****************************************************


'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
'vbYes also does this section between & lines
'Should not require the extra If/end If.
If Response = vbYes Then

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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("a13").Value & " " & "PIP ACCEPTED"

On Error Resume Next
With OutMail
.To = "(e-mail address removed); (e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "PIP Accepted"
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End If
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&


'#################################################
'vbNo does all this between # lines
If Response = vbNo Then
DefaultFolder = "M:\Procurement\Declined PIPS"
If Right(DefaultFolder, 1) <> "\" Then
DefaultFolder = DefaultFolder & "\"
End If

DefaultFileName = "Declined PIP" & " for " &
Sheets("PIP").Range("A13").Value

If Right(UCase(DefaultFileName), 3) <> "XLS" Then
DefaultFileName = DefaultFileName & " " & _
Format(Date, "dd-mm-yyyy") & ".xls"
End If

FileToSave = Application.GetSaveAsFilename _
(DefaultFolder & DefaultFileName, filefilter:="Excel Files (*.xls)," _
& "*.xls", Title:="Save File As...")

If FileToSave = False Then
Exit Sub
Else
ThisWorkbook.SaveAs _
Filename:=FileToSave, _
FileFormat:=ActiveWorkbook.FileFormat
End If

End If
'#################################################



'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Both vbYes and vbNo does all between @ lines
'All this should all be within the vbNo If/End If section
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("C10").Value & " " & "PIP DECLINED"

On Error Resume Next
With OutMail
.To = "(e-mail address removed); (e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "PIP Declined"
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Exit Sub 'Not required
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
End Sub