Solved

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

Posted on 2014-04-07
6
625 Views
Last Modified: 2014-04-08
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
0
Comment
Question by:kbay808
  • 3
  • 3
6 Comments
 
LVL 50

Expert Comment

by:Rgonzo1971
ID: 39985131
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
 

Author Comment

by:kbay808
ID: 39985179
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
 
LVL 50

Expert Comment

by:Rgonzo1971
ID: 39985206
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
Networking for the Cloud Era

Join Microsoft and Riverbed for a discussion and demonstration of enhancements to SteelConnect:
-One-click orchestration and cloud connectivity in Azure environments
-Tight integration of SD-WAN and WAN optimization capabilities
-Scalability and resiliency equal to a data center

 

Author Comment

by:kbay808
ID: 39985264
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
 
LVL 50

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 39985583
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
 

Author Closing Comment

by:kbay808
ID: 39986545
It works great!!!  Thank you very much
0

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
With User Account Control (UAC) enabled in Windows 7, one needs to open an elevated Command Prompt in order to run scripts under administrative privileges. Although the elevated Command Prompt accomplishes the task, the question How to run as script…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

820 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question