Solved

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

Posted on 2014-04-07
6
626 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 3
6 Comments
 
LVL 51

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 51

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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

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 51

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

Enroll in May's Course of the Month

May’s Course of the Month is now available! Experts Exchange’s Premium Members and Team Accounts have access to a complimentary course each month as part of their membership—an extra way to increase training and boost professional development.

Question has a verified solution.

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

Microsoft Office Picture Manager is not included in Office 2013. This comes as a shock to users upgrading from earlier versions of Office, such as 2007 and 2010, where Picture Manager was included as a standard application. This article explains how…
This article describes a serious pitfall that can happen when deleting shapes using VBA.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

734 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