Solved

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

Posted on 2014-04-07
6
617 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 48

Expert Comment

by:Rgonzo1971
Comment Utility
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
Comment Utility
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 48

Expert Comment

by:Rgonzo1971
Comment Utility
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
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

by:kbay808
Comment Utility
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 48

Accepted Solution

by:
Rgonzo1971 earned 500 total points
Comment Utility
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
Comment Utility
It works great!!!  Thank you very much
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Not long ago I saw a question in the VB Script forum that I thought would not take much time. You can read that question (Question ID  (http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28455246.html)28455246) Here (http…
My experience with Windows 10 over a one year period and suggestions for smooth operation
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
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…

772 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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now