excel macro help - range to email

imjayfrank
imjayfrank used Ask the Experts™
on
Hi,
I have a macro which takes a range from excel and converts it to HTML and sends in an outlook email.

Can anyhelp me direct me to how to add in my code to take the range and convert it as an image? Then use that image in the email body?

Thanks.
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Good Morning,

In excel you can copy a range as a picture:

    Application.CutCopyMode = False
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

I'm trying to see how to get it in the email body.

Do you have the spreadsheet you could attach?

Author

Commented:
Sub LightningBolt1_Click()
Dim myOlApp As Object
Dim MyItem As Object
Dim strBody As String
Dim strLink As String
Dim strLinkText As String
Dim strNewText As String
Dim strNewText2 As String
'Dim vNewText As Variant


Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItemFromTemplate("H:\Snapshot.oft")
With MyItem
.bcc = "Clients Names Here"
.cc = "email"
.Subject = "Snapshot "
strBody = .HTMLBody
'strNewText = "<p>this is a test</p>"
strNewText = RangetoHTML(Range("A3:E60"))
strNewText2 = Date

'vNewText = Cells.Range("A3:E60")
'Dim i As Long
'For i = LBound(vNewText) To UBound(vNewText)
  'If strNewText = vbNullString Then
    'strNewText = vNewText(i)
 'Else
    'strNewText = strNewText & vbCrLf & vNewText(i)
 ' End If
'Next i
         
.HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX") 'test iAddOption = 1 @ replace search string in body
.HTMLBody = getNewHTML(.HTMLBody, strNewText2, 2, "XXXDateXXX")
'.HTMLBody = strNewText
.Display
End With
Set MyItem = Nothing
Set myOlApp = Nothing

End Sub
Function RangetoHTML(rng As Range)
    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
Sub SendEmailWTemplate()
Dim myOlApp As Object
Dim MyItem As Object
Dim strBody As String
Dim strLink As String
Dim strLinkText As String
Dim strNewText As String

    Set myOlApp = CreateObject("Outlook.Application")
    Set MyItem = myOlApp.CreateItemFromTemplate([oftTemplate]) 'using named range for template path

    With MyItem
        .To = Sheets("Clients").Range("A1")
        .Subject = "Monthly bill"
        
        strNewText = [replaceString]

        Select Case [desiredoption]
            Case 1
                .HTMLBody = getNewHTML(.HTMLBody, strNewText, 1, vbNullString) 'test iAddOption = 0 @ beginning of body
            Case 2
                .HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, [findString]) 'test iAddOption = 1 @ replace search string in body
            Case 3
                .HTMLBody = getNewHTML(.HTMLBody, strNewText, 3, vbNullString) 'test iAddOption = 2 @ end of body
        End Select
        
        .Display
    End With
    Set MyItem = Nothing
    Set myOlApp = Nothing
End Sub
Function getNewHTML(strHTML As String, strBodyTagReplace As String, iAddOption As Integer, Optional strBodyTag As String = vbNullString) As String
'Source: Learnings from - http://msdn.microsoft.com/en-us/library/dd492012(v=office.12).aspx
'supports adding at the beginning of the message, before the template, adding in the middle of the existing HTML, or at the end of the message
'iAddOption = 1 'beginning of email body - keys in on <body and inserts after the <body xxx declaration
'iAddOption = 2 'middle of email body (requires a search string to be added)
'iAddOptin = 3 'end of the email body - keys in on and inserts before </body>

Dim intTagStart As Integer
Dim intTagEnd As Integer

    Select Case iAddOption
        Case 1 'Insert at beginning of email body
            intTagStart = InStr(1, strHTML, "<body", vbTextCompare)
            intTagEnd = InStr(intTagStart + 5, strHTML, ">")
            strBodyTag = Mid(strHTML, intTagStart, intTagEnd - intTagStart + 1)
            getNewHTML = Replace(strHTML, strBodyTag, strBodyTagReplace)
        Case 2 'Search for key string and insert in the middle of email body
            getNewHTML = Replace(strHTML, strBodyTag, strBodyTagReplace)
        Case 3 'Append to end of email body
            getNewHTML = Replace(strHTML, "</body>", strBodyTagReplace, 1, 1, vbTextCompare)
    End Select
    
End Function

Open in new window

Here is an brief example for copying in excel and pasting in outlook

    Dim outobj As Object
    Dim myOLItem As Object
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection
    Set outobj = CreateObject("outlook.application")
    Set outNameSpace = outobj.GetNamespace("MAPI")

    Range("A1:I4").Select
    'copies the selection as a picture
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set myOLItem = outobj.CreateItem(olMailItem)
    Set objDoc = myOLItem.GetInspector.WordEditor
    Set objSel = objDoc.Windows(1).Selection
    With objSel
      'pastes the picture
        .Paste
    End With
    myOLItem.Display

Open in new window

There's likely pently of code on the net for this, my 2 cents is that I highly recommending using SMTP.  

If you try and use the outlook interface it has a few popups built not to be able to be coded around so that outlook can't be used to spam quite as easy.

Here's a great resource for SMTP(CDO):

http://www.databison.com/index.php/3-nifty-ways-to-send-email-using-excel/

Author

Commented:
steve,
that does work, thanks.

but how can i incorporate it with my existing code where I use a layout template in outlook and replace the text with specific words in the template:

Set myOLapp = CreateObject("Outlook.Application")
Set myitem = myOLapp.CreateItemFromTemplate("H:\Snapshot.oft")
With myitem
.bcc = "Clients Names Here"
.cc = "emails"
.Subject = "snapshot"
strBody = .HTMLBody
strNewText = RangetoHTML(Range("A3:E60"))
strNewText2 = Date

.HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX") .HTMLBody = getNewHTML(.HTMLBody, strNewText2, 2, "XXXDateXXX")
.Display
End With
Set myitem = Nothing
Set myOLapp = Nothing
Here you go. I hopefully renamed thing right. :)

Sub LightningBolt1_Click()
Dim myOlApp As Object
Dim MyItem As Object
Dim strBody As String
Dim strLink As String
Dim strLinkText As String
Dim strNewText As String
Dim strNewText2 As String

'Code addition from Steve
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection

'Dim vNewText As Variant


Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItemFromTemplate("H:\Snapshot.oft")
With MyItem
.bcc = "Clients Names Here"
.cc = "email"
.Subject = "Snapshot "
strBody = .HTMLBody
'strNewText = "<p>this is a test</p>"
' comment out
'strNewText = RangetoHTML(Range("A3:E60"))

strNewText2 = Date
'Steve's code

Range("A3:E60").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objDoc = MyItem.GetInspector.WordEditor
    Set objSel = objDoc.Windows(1).Selection
    With objSel.Find
        .Text = "XXXTextToReplaceXXX"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    objSel.Find.Execute
    
    objSel.Paste
    With Selection.Find
        .Text = "XXXDateXXX"
        .Replacement.Text = strNewText2
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll


'vNewText = Cells.Range("A3:E60")
'Dim i As Long
'For i = LBound(vNewText) To UBound(vNewText)
  'If strNewText = vbNullString Then
    'strNewText = vNewText(i)
 'Else
    'strNewText = strNewText & vbCrLf & vNewText(i)
 ' End If
'Next i
         
'.HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX") 'test iAddOption = 1 @ replace search string in body
'.HTMLBody = getNewHTML(.HTMLBody, strNewText2, 2, "XXXDateXXX")
'.HTMLBody = strNewText
.Display
End With
Set MyItem = Nothing
Set myOlApp = Nothing

End Sub

Open in new window

Author

Commented:
looks good, thanks.

only issue is it stops at:
With Selection.Find

"wrong number of arguments or invalid property assignment"
run time error 450.
hmmmm.

in the Visual basic window make sure under tools-references that Microsoft Word 12.0 Object Library is checked.

VBA reference selection

Author

Commented:
I have the Microsoft Word 14.0 Object Library checked.

i dont have the 12.0 there.

Author

Commented:
I have found 12.0 and checked it. Same error.
in word record a macro for find and replace then copy that code over and change Selection to objSel
I'm on Word 2007 and excel 2007

When I get home I can see on 2010. :)

Author

Commented:
as am i.

Author

Commented:
ah my excel and word is 07, but my outlook is 2010.

any help would be appreciated!
when you recorded the find macro in word did the code look different?

The code is running on my machine fine.
This is the code I get in Word when recording the macro:

    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "XXXTextToReplaceXXX"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute

Open in new window

I have 2010 at home. I'll see about it.

Author

Commented:
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "XXXTextToReplaceXXX"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

Open in new window

Author

Commented:
it works. i figured it out.

i replaced all the Selection.Find to objSel.Find

looks good!

what are the chances you can help me in resizing the image a bit smaller in the code?
try adding

objSel.Shrink after objSel.Paste
It appears you are using Ron's Sub Mail_Sheet_Outlook_Body ()    AND  Function RangetoHTML (rng as Range)  to create and mail the used range of an excel sheet.  Since this will not email a picture you can use MailEnvelope.

Use the Excel Camera Tool to create a picture of your data on a seperate worksheet and then use MailEnvelope to send the worksheet that contains the picture.

MailEnvelope:
Quick Access Toolbar / Command Not in the Ribbon / Send to Mail Recipient.  This will allow you to do the process manually from the QAT to become familiar with it.   To automate the process, use Ron's VBA Code at - http://www.rondebruin.nl/mail/folder3/mailenvelope.htm

Camera Tool:
Quick Access Toolbar / All Commands / Camera
EE Article by harfang - http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/A_1789-Excel-Tips-Tricks-The-Camera-Tool.html

VBA to Automate the Camera Tool:
This post uses the CopyPicture method mentioned earlier in this thread:   http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_20928550.html
 
Thanks,
ProdOps
You can add font and auto fit comands around the copy picture statement:

Range("A3:E60").Font.Size = 9
Columns("A:E").EntireColumn.AutoFit
Range("A3:E60").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Range("A3:E60").Font.Size = 11
Columns("A:E").EntireColumn.AutoFit

Open in new window

Author

Commented:
cheers steve.

Author

Commented:
Great to deal with!

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial