Untested but should be close
Sub Attach_selected_slides()
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim otemp As Presentation
Dim opres As Presentation
Dim strName As String
Dim strSubject As String
Dim L As Long
Dim raySlides() As Long
Set opres = ActivePresentation
Call zaptags(opres)
strSubject = opres.Name
strName = killSuffix(opres.Name) & " s_"
ReDim raySlides(1 To ActiveWindow.Selection.SlideRange.Count)
For L = 1 To ActiveWindow.Selection.SlideRange.Count
ActiveWindow.Selection.SlideRange(L).Tags.Add "SELECTED", "YES"
If L <> ActiveWindow.Selection.SlideRange.Count Then
strName = strName & ActiveWindow.Selection.SlideRange(L).SlideIndex & "_"
Else
strName = strName & ActiveWindow.Selection.SlideRange(L).SlideIndex
End If
Next L
' make a copy
opres.SaveCopyAs Environ("TEMP") & "\" & strName & ".pptx"
'open the copy
Set otemp = Presentations.Open(Environ("TEMP") & "\" & strName & ".pptx")
'delete unwanted slides
For L = otemp.Slides.Count To 1 Step -1
Debug.Print otemp.Slides(L).Tags("SELECTED")
If otemp.Slides(L).Tags("SELECTED") <> "YES" Then otemp.Slides(L).Delete
Next L
otemp.Save
otemp.Close
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application")
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application")
On Error GoTo 0
Set OutlookMessage = OutlookApp.CreateItem(0)
On Error Resume Next
With OutlookMessage
.To = "john@pptalchemy.co.uk" 'Insert email address here!
.CC = ""
.Subject = strSubject
.Body = "Slides are attached. Alex"
.Attachments.Add Environ("TEMP") & "\" & strName & ".pptx"
.Display
End With
End Sub
Sub zaptags(opres)
Dim osld As Slide
On Error Resume Next
For Each osld In opres.Slides
osld.Tags.Delete ("SELECTED")
Next osld
End Sub
Function killSuffix(strName As String) As String
Dim ipos As Integer
ipos = InStrRev(strName, ".")
If ipos > 0 Then
killSuffix = Left(strName, ipos - 1)
Else: killSuffix = strName
End If
End Function