Code to create pre set emails in outlook

[Akhil333]

Dear Team,

Please provide your assistance in sharing with me a code to create pre set emails in outlook.

 

[Jeffrey Mahoney]

Here is some code that I use for dozens of different emails that I send out each month. I have a daily tracker WB that allows me to open necessary files, provide links to applications, and create emails with attachments. I have code to allow me to double click on the email column in the tracker

This is a setup for one of my emails. I add formulas to change the Subject and other parameters within the body of the email

Daily Manager_2.xlsm
	BL
2	Early Phase Meeting Pre-Read
3	Early Phase Cost and Schedule Meeting - Pre-Read May [CSPR]
4	YourEmailHere@gmail.com
5	YourListofEmails@gmail.com; EmailsSeparatedBySemicolon@gmail.com
6
7	YourEmailHere@gmail.com
8	Early Phase Meeting Pre-Read 2024_05.xlsm
9	Q:\IC&SC\6.Central Team\2. Report Working Files\Meetings\Early Phase\
10	<p>All,</p> <p>Attached are the pre-read materials for tomorrow morning’s meeting.</p> <ul> <li>Option Selection Report</li> <li>Endorsed Project Tracker</li> </ul> <br> One pagers for projects reviewed at yesterday’s PMT meeting can be found by clicking on the links below.<br><br><br><br><br> <br><br> Jeff Mahoney
11	2024_05
Emails

Cell Formulas
Range	Formula
BL3	BL3	="Early Phase Cost and Schedule Meeting - Pre-Read "&TEXT(TODAY(),"MMMM")&" [CSPR]"
BL8	BL8	="Early Phase Meeting Pre-Read "&BL11&".xlsm"
BL11	BL11	=TEXT(TODAY(),"YYYY")&"_"&TEXT(TODAY(),"MM")

Here is a visual of the same thing

Code to check for double click on tracker sheet. The cell that I double click on has the name of email (in blue). It finds the email and loads all the data and calls the SUB below. This code is in a SHEET module in VBA

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim i As Range
    Dim R As Range
    Dim Cel As Range
    Dim EmailName As String
    Dim HyperlinkStr As String
    Dim Path As String
    Dim FileName As String
   
      
    Set R = Range("ChckLst_Tbl[Email]")
    Set i = Intersect(R, Target)
    If Not i Is Nothing Then
      EmailName = i.Value
      If EmailName <> "" Then
        Cancel = True
        With EmailSht
          Set R = .Range("EmailNameRow")
          For Each Cel In R
            If Cel.Value = EmailName Then
              EmailSubject = Intersect(Cel.EntireColumn, .Range("EmailSubjectRow")).Value                'Cel.Offset(1, 0).Value
              EmailFrom = Intersect(Cel.EntireColumn, .Range("EmailFromRow")).Value
              EmailTo = Intersect(Cel.EntireColumn, .Range("EmailToRow")).Value
              EmailCC = Intersect(Cel.EntireColumn, .Range("EmailCCRow")).Value
              EmailBCC = Intersect(Cel.EntireColumn, .Range("EmailBCCRow")).Value
              EmailFileName = Intersect(Cel.EntireColumn, .Range("EmailAttachRow")).Value
              EmailPath = Intersect(Cel.EntireColumn, .Range("EmailPathRow")).Value
              EmailBody = Intersect(Cel.EntireColumn, .Range("EmailBodyRow")).Value
              Call CreateEmail
              Exit For
            End If
          Next Cel
        End With
      End If
    End If
   
   
End Sub

Code to create the email in a standard module

Public EmailTo As String
Public EmailFrom As String
Public EmailCC As String
Public EmailBCC As String
Public EmailSubject As String
Public EmailBody As String
Public EmailPath As String
Public EmailFileName As String



Sub CreateEmail()

  Dim objOutlook As Object
  Dim objMail As Object
  Dim A As String
  Dim Q As String
  Dim OutAccnt As Outlook.account
  Dim xOutMsg As String
  Dim Hrt As String
  Dim EmailFile(10) As String
  Dim EmailFileCnt As Long
  Dim X As Long
  Dim Y As Long
  Dim s1 As Long
  Dim s2 As Long
  Dim EmailPathFile As String
  Dim PathFileError As String
 
 
  Set objOutlook = CreateObject("Outlook.Application")
  Set objMail = objOutlook.CreateItem(0)
  If EmailFrom <> "" Then
    Set OutAccnt = objOutlook.Session.Accounts.Item(EmailFrom)
  End If
 

  xOutMsg = "<font style=font-size:14pt;font-family:Calibri;color:#000000>"
  xOutMsg = xOutMsg & EmailBody & vbNewLine & "</font>"
 
  If EmailPath <> "" And Right(EmailPath, 1) <> "\" Then EmailPath = EmailPath & "\"
 
  If EmailFileName <> "" Then
    EmailFileCnt = Len(EmailFileName) - Len(Replace(EmailFileName, ";", "")) + 1
    If EmailFileCnt = 1 Then
      EmailFile(1) = EmailFileName
    Else
      For X = 1 To EmailFileCnt
        s2 = InStr(s1 + 1, EmailFileName, ";")
        If X = 1 Then
          EmailFile(1) = Trim(Left(EmailFileName, s2 - 1))
          s1 = s2
        ElseIf X = EmailFileCnt Then
          EmailFile(X) = Mid(EmailFileName, s1 + 1, 100)
        ElseIf X > 1 And X < EmailFileCnt Then
          EmailFile(X) = Trim(Mid(EmailFileName, s1 + 1, s2 - s1 - 1))
          s1 = s2
        End If
      Next X
    End If
  End If
   
              
  With objMail
   
    .BodyFormat = olFormatHTML
    .SendUsingAccount = OutAccnt              'Supposedly allows the correct Signature to be loaded
    If EmailFrom <> "" Then
      .SentOnBehalfOfName = EmailFrom           'OutAccnt            'Group email account
    End If
    .To = EmailTo
    .CC = EmailCC
    .BCC = EmailBCC
    .Subject = EmailSubject
    .Display                   'Instead of .Display, you can use .Send to send the email
    .HTMLBody = xOutMsg & .HTMLBody               'Put this after .Display to save the signature
    'Error.Clear
    On Error GoTo WeThePeople
    For X = 1 To EmailFileCnt
      EmailPathFile = EmailPath & EmailFile(X)
      PathFileError = EmailPathFile
      .Attachments.Add EmailPathFile, 1
    Next X

    '.Send                                 or .Save to save a copy in the drafts folder
  End With


  Set objOutlook = Nothing
  Set objMail = Nothing
  Exit Sub
 
WeThePeople:
  MsgBox "There was a problem attaching this file: " & vbNewLine & PathFileError


End Sub

You will need to load the reference below in VBA