Solved

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

Posted on 2014-04-07
6
624 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 49

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 49

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
PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

 

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 49

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

PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

Question has a verified solution.

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

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

803 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