Macro Help

[Neil Holden]

Morning all Gurus, I have a button so when pressed it will save the workbook
and if YES is pressed it will email certain people, the email address are
hard coded in VB. The trouble is when certain excels sheet are submitted I
don't want it to go to all email addresses, ideally I would like the user to
select which email addresses to send it too. For example if i have 6 email
addresses I would like the user to be able to select any out of the 6, this
might be 3 emails or more or less.

Please help. The code is shown below:

If Response = vbYes Then

ActiveWorkbook.Save

Dim OutApp As Object 'this emails operations manager
Dim OutMail As Object
Dim strbody As String

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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("B13").Value & " " & "Ready For Review"

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

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

 

[Joel]

You should put the email addresses on the worksheet witth the persons name in
one column and there email address in a 2nd column You need to generate a box
to select multiple different responses. You could use a listbox to perform
this task. Better with a userform.

A siomplier approach would be to use an input box and hold down the cntrl
key so you can sselect multiple entries. I modified you code to do this

If Response = vbYes Then

ActiveWorkbook.Save

Dim OutApp As Object 'this emails operations manager
Dim OutMail As Object
Dim strbody As String

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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("B13").Value & " " & "Ready For Review"


Set Response = Application.InputBox("Select Email Address" & vbCrLf & _
"Hold down Contrl Key to select multiple addresses", Type:=8)
Destination = ""
For Each cell In Response
If Destination = "" Then
Destination = cell
Else
Destination = Destination & ";" & cell
End If

Next cell

On Error Resume Next
With OutMail
.To = Destination
.CC = ""
.BCC = ""
.Subject = "PIP Ready For Review"
.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

 

[Neil Holden]

Thanks for your help Joel, I've tried setting up a list box but can't select
multiple email addresses, can you have a look at the code below? I gave you
the wrong code my mistake, i'm sorry. Ideally i would like the button to
be pressed and it will take "are you sure you want to save this PIP?" and
then the list of email address appears and then they select and submit.

Sorry to be a pain and i really appreciate your help with this matter.

Sub Macro()

Dim Response As String
Dim DefaultFolder As String, DefaultFileName As String
Dim FileToSave

Response = MsgBox("Are you sure you want to save the PIP report?", _
vbYesNo + vbInformation + vbDefaultButton2)

If Response = vbYes Then

ActiveWorkbook.Save

Dim OutApp As Object 'this emails operations manager
Dim OutMail As Object
Dim strbody As String

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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("B13").Value & " " & "Ready For Review"

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

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

'If Response = vbYes Then
' DefaultFolder = "M:\Contract\Current\Nationwide\Templates\Project
Brief&SOR\Project Briefs to be Approved prior to sending inc master SOR
Project brief"
'If Right(DefaultFolder, 1) <> "\" Then
' DefaultFolder = DefaultFolder & "\"
'End If
'DefaultFileName = Range("C7")
'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
End If
End Sub









Thanks for your reply Joel.

 

[Joel]

Here is the new code. I don't see any list box code in your macro. There is
a listbox parameter you must set for multiselect.

SEE VBA HELP : MultiSelect Property

there are two different options for multiselect

If you are using the inputbox I put my code into your lastest macro below.
To select more than one item first select the first item and then press
control key and hold the control key down while selecting the other items.


Sub Macro()

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 save the PIP report?", _
vbYesNo + vbInformation + vbDefaultButton2)

If Response = vbYes Then

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("B13").Value & " " & "Ready For Review"


Set EmailAddr = Application.InputBox("Select Email Address" & vbCrLf & _
"Hold down Contrl Key to select multiple addresses", Type:=8)
Destination = ""
For Each cell In EmailAddr
If Destination = "" Then
Destination = cell
Else
Destination = Destination & ";" & cell
End If

Next cell


ActiveWorkbook.Save


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

strbody = "PIP" & " for " & Sheets("PIP").Range("A13").Value & " " & _
Sheets("PIP").Range("B13").Value & " " & "Ready For Review"

On Error Resume Next
With OutMail
.To = Response
.CC = ""
.BCC = ""
.Subject = "PIP Ready For Review"
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0

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

'If Response = vbYes Then
' DefaultFolder = "M:\Contract\Current\Nationwide\Templates\Project
'Brief&SOR\Project Briefs to be Approved prior to sending inc master SOR
'Project brief"
'If Right(DefaultFolder, 1) <> "\" Then
' DefaultFolder = DefaultFolder & "\"
'End If
'DefaultFileName = Range("C7")
'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
End If
End Sub