Outlook Email & Reminder from Excel

Okay,

I've not really had any interest from anyone on the forum so far but thought I would give an update on what I've managed so far anyway in case it helps someone else in the future.

I've manage to create a totally separate task with a reminder.

Unfortunately this is not really ideal as I will now have two copies of the PDF attachment on my outlook email account (one in the sent items & one attached to the new Task).

Also I liked the idea of having the reminder linked directly to the sent email message to make things easier to track and follow up.

Sub SaveFileAs()

    Dim CurrFile As String
    Dim WasSaved As Boolean
    Dim ret As Boolean
    Dim IsCreated As Boolean
    Dim i As Long
    Dim PdfFile As String, Title As String, mailBody As String
    Dim OutlApp As Object
    Dim cc_emailRng As Range, cl As Range
    
    
    Set cc_emailRng = Range("cc_emails")
    
    For Each cl In cc_emailRng
        scc = scc & ";" & cl.Value
    Next
    scc = Mid(scc, 2)
          
    On Error Resume Next
     
    WasSaved = False
    
    On Error Resume Next
    ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & "RFI - " & Range("D9").Value & "_" & Range("H4").Value & ".xls"
    
    If Err.Number = 0 Then
        WasSaved = True
    
   
    End If
        
    On Error Resume Next
    
    If WasSaved = True Then
    
    
    
    CurrFile = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
    
    Else
        Err.Clear
        ret = Application.Dialogs(xlDialogSaveAs).Show
        
        If ret = True Then
        'saved with some name
        WasSaved = True
        End If
    End If
          
    On Error Resume Next
    
    If WasSaved = False Then
   
        MsgBox "Not Saved!" & vbNewLine & vbNewLine _
        & "If you are experiencing any problems " & vbNewLine & _
        "please contact ...", vbExclamation
    
    End If
    
    Title = "Request For Information - " & Range("D9").Value & "_" & Range("H4").Value
    ' Define PDF filename
    PdfFile = ActiveWorkbook.FullName
    i = InStrRev(PdfFile, ".")
    If i > 1 Then PdfFile = Left(PdfFile, i - 1)
    PdfFile = PdfFile & ".pdf"
 
    ' Export activesheet as PDF
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
 
    ' Use already open Outlook if possible
    On Error Resume Next
    Set OutlApp = GetObject(, "Outlook.Application")
    
    If Err Then
        Set OutlApp = CreateObject("Outlook.Application")
        IsCreated = True
    End If
  
    If ActiveSheet.Shapes("Check Box 1").ControlFormat.Value = 1 Then
        mailBody = "Please note: Cost/Time Implications do apply. <br>"
    Else: mailBody = " "
    End If
  
  If WasSaved = True Then
   
    MsgBox "Excel Workbook Saved as: " & vbNewLine & _
    ActiveWorkbook.FullName & vbNewLine & vbNewLine & _
    "PDF Saved as: " & vbNewLine & _
    PdfFile & vbNewLine, , "Files Saved"
  
  End If
  
  On Error Resume Next
   
  OutlApp.Visible = True
  On Error GoTo 0
 
  ' Prepare e-mail with PDF attachment
  With OutlApp.CreateItem(0)
   
    ' Prepare e-mail
    .Display
    signiture = .HTMLBody
    '.SentOnBehalfOfName = Range("Originator").Value & "<" & Range("globalEmail") & ">"
    .Subject = Title
    .To = Range("email").Value ' <-- Put email of the recipient here
    .CC = scc ' <-- Put email of 'copy to' recipient here
    .HTMLBody = "<H3></H3>" & _
    "Attention:  " & Range("D8").Value & "<br><br>" _
    & "Please find Request for Information Number " & Range("H4").Value & " attached for " & Range("D9").Value & "<br><br>" _
    & "Originator:  " & Range("Originator").Value & "<br><br>" _
    & mailBody & "<br><br>" _
    & "Please Return Response To: ...<br>" _
    & "Response Required by: " & Range("H8").Value & "<br>" _
    & "For the Attention of: " & Range("globalAttention").Value & "<br>" _
    & "Fax: " & Range("globalFax").Value & "<br>" _
    & "Telephone: " & Range("globalTelephone").Value & "<br>" _
    & "Email: " & Range("globalEmail").Value & "<br>" _
    & signiture
    .Attachments.Add PdfFile
    '.FlagStatus = olFlagMarked
    '.FlagRequest = "Follow up"
    '.FlagDueBy = Format(DateAdd("d", -0, CDate(Range("H8").Value) & " 09:30 AM"))
    
    With OutlApp.CreateItem(3)
        .Subject = Title
        '.StartDate = Format(DateAdd("d", -0, CDate(Range("H8").Value)))
        .DueDate = Format(DateAdd("d", -0, CDate(Range("H8").Value)))
        .ReminderPlaySound = True
        .ReminderSet = True
        .ReminderTime = .DueDate - 1
        .Body = "Follow up RFI Number " & Range("H4").Value & " attached for " & Range("D9").Value & vbNewLine _
        & "To the Attention of:  " & Range("D8").Value & vbNewLine _
        & "Originator:  " & Range("Originator").Value & vbNewLine _
        & "Response Required by: " & Range("H8").Value
        .Attachments.Add PdfFile
        .Display
        '.Save
    End With
    
   
    ' Try to send
    '.Send
    On Error Resume Next
    .Display
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      'MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
   
  End With
  
  If WasSaved = False Then
    Kill PdfFile ' Delete PDF file
  End If
   
  ' Quit Outlook if it was created by this code
  'If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
  Set OutlApp = Nothing
 
End Sub