How to create a macro in Excel to create an email using the data in the spreadsheet

I want to create a macro to create an email using the below data:

To: Data from cell A10
From: FSQM (Not sure if this is possible, but it’s a group mailbox)
Subject: Data from cell A13

Sheet name: HPSM
Email-Tool.xlsm
kbay808Asked:
Who is Participating?
 
Rgonzo1971Commented:
Hi,

pls try

Sub MailActiveSheet()
    Dim OL_App As Object
    Dim OL_Mail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set rng = ActiveSheet.UsedRange
   
    Set OL_App = CreateObject("Outlook.Application")
    Set OL_Mail = OL_App.CreateItem(0)

    With Destwb
        On Error Resume Next
        With OL_Mail
            Set .SendUsingAccount = .Session.Accounts.Item("FSQM")
            .To = Range("A10")
            .CC = ""
            .BCC = ""
            .Subject = Range("A13")
            .Display '.Send
            .HTMLBody = RemoveSignature(.HTMLBody)
        End With
        On Error GoTo 0
    End With


    Set OL_Mail = Nothing
    Set OL_App = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function RemoveSignature(strHTMLBODY As String)
On Error GoTo 0
strStartPTag = "<p class="
strSearTag = "style='mso-bookmark:_MailAutoSig'"
strEndPTag = "</p>"
TagIndex = InStr(strHTMLBODY, strSearTag)
startPTagIndex = 0
Debug.Print strHTMLBODY
endPTagIndex = 0
PosNavigator = 0
    While (TagIndex > 0)
        startPTagIndex = 0
        endPTagIndex = 0
        PosNavigator = 0
        PosNavigator = TagIndex

        Do While (PosNavigator > 0)
            If (Mid(strHTMLBODY, PosNavigator, Len(strStartPTag)) = strStartPTag) Then
                startPTagIndex = PosNavigator
                Exit Do
            End If
            PosNavigator = PosNavigator - 1
            endPTagIndex = InStr(TagIndex, strHTMLBODY, strEndPTag)
        Loop
        If (startPTagIndex > 0 And endPTagIndex > 0) Then
            strHTMLBODY = Mid(strHTMLBODY, 1, startPTagIndex - 1) & Mid(strHTMLBODY, endPTagIndex + Len(strEndPTag), Len(strHTMLBODY))
        End If
        TagIndex = InStr(strHTMLBODY, strSearTag)
    Wend
RemoveSignature = strHTMLBODY
End Function

Open in new window

Regards
0
 
Rgonzo1971Commented:
Hi,

pls adapt and try

Sub MailActiveSheet()
    Dim OL_App As Object
    Dim OL_Mail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook
   
    TempFilePath = Environ$("temp") & "\"
    TempFileName = Sourcewb.ActiveSheet.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OL_App = CreateObject("Outlook.Application")
    Set OL_Mail = OL_App.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & ".xlsm", 52
        On Error Resume Next
        With OL_Mail
            Set .SendUsingAccount = .Session.Accounts.Item("FSQM")
            .To = Range("A10")
            .CC = ""
            .BCC = ""
            .Subject = Range("A13")
            .Body = "Hi World"
            .Attachments.Add Destwb.FullName
            .Display '.Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & ".xlsm"

    Set OL_Mail = Nothing
    Set OL_App = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Open in new window

Regards
0
 
kbay808Author Commented:
Could you please make 2 changes?  First, could you remove the workbook from being attached in the email?  And second, is there a way not to remove the signature block that is usually automatically added?  Thanks
0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
Rgonzo1971Commented:
Hi,

pls try
Sub MailActiveSheet()
    Dim OL_App As Object
    Dim OL_Mail As Object

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set rng = ActiveSheet.UsedRange
   
    Set OL_App = CreateObject("Outlook.Application")
    Set OL_Mail = OL_App.CreateItem(0)

    With Destwb
        On Error Resume Next
        With OL_Mail
            Set .SendUsingAccount = .Session.Accounts.Item("FSQM")
            .To = Range("A10")
            .CC = ""
            .BCC = ""
            .Subject = Range("A13")
            .HTMLBody = RangetoHTML(rng)
            .Display '.Send
        End With
        On Error GoTo 0
    End With


    Set OL_Mail = Nothing
    Set OL_App = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function RangetoHTML(ByVal rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Open in new window

Regards
0
 
kbay808Author Commented:
I’m sorry, but I must not have made my request clear.  I do not need anything in the body of the email except for the Outlook default signature, if possible.
0
 
kbay808Author Commented:
It works great!!!  Thank you very much
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.