excel macro to send outlook template

Hi,
I'm having issues with my macro. It should send the data via email using my outlook template, however for some reason when it composes the email, it attaches a file and its not using a template.

Any ideas?

Sub test2()
Dim myOlApp As Object
Dim MyItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set MyItem = myOlApp.CreateItemFromTemplate("H:\FOLDER\Macros\Snapshot.oft")

With MyItem
.To = Sheets("Clients").Range("A1")
.Subject = "Monthly bill"
.HTMLBody = "Test"
'Refer to and fill in variable items in template
.Display
End With
Set MyItem = Nothing
Set myOlApp = Nothing
End Sub
imjayfrankAsked:
Who is Participating?
Advertise Here
 
dlmilleConnect With a Mentor Commented:
Here's your code and it works like a champ!

Option Explicit

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

    Set myOlApp = CreateObject("Outlook.Application")
    Set MyItem = myOlApp.CreateItemFromTemplate("H:\FOLDER\Macros\Snapshot.oft")

    With MyItem
        .To = Sheets("Clients").Range("A1")
        .Subject = "Monthly bill"

        strNewText = "<p>this is a test</p>"

        '.HTMLBody = getNewHTML(.HTMLBody, strNewText, 1, vbNullString) 'test iAddOption = 0 @ beginning of body
        .HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX")    'test iAddOption = 1 @ replace search string in body
        '.HTMLBody = getNewHTML(.HTMLBody, strNewText, 3, vbNullString) 'test iAddOption = 2 @ end of body

        .Display
    End With
    Set MyItem = Nothing
    Set myOlApp = Nothing
End Sub
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

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


    Set myOlApp = CreateObject("Outlook.Application")
    Set MyItem = myOlApp.CreateItemFromTemplate("C:\Users\dmbw\AppData\Roaming\Microsoft\Templates\test html.oft")

    With MyItem
        .bcc = "Clients Names Here"
        .cc = "cc here"
        .Subject = "subject here"
        strBody = .HTMLBody
        'Set rangebody = Cells.Range("a3:e60")
        'strNewText = "<p>this is a test</p>"
        strNewText = RangetoHTML(Range("A3:E60"))
        strNewText2 = Date

        .HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX")    'test iAddOption = 1 @ replace search string in body
        .HTMLBody = getNewHTML(.HTMLBody, strNewText2, 2, "XXXDateXXX")
        .Display
    End With
    Set MyItem = Nothing
    Set myOlApp = Nothing

End Sub

Open in new window


In a separate public module (just to keep the standard function separate) is Ron's code:
Option Explicit

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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


Cheers,

Dave
sendEmailUsingTemplate-r3.xlsm
0
 
imjayfrankAuthor Commented:
I dug a bit deeper and seems the template is just fine until I add the .HTMLBody.

How can I add the .HTMLBody over the template without it being messed up?

Once I add the .HTMLBody, then the template gets messed up.
0
 
dlmilleCommented:
If you examine the MailItem object (e.g., you can do that by stepping through your code, watching the MyItem variable)

The command:

Set MyItem = myOlApp.CreateItemFromTemplate("H:\FOLDER\Macros\Snapshot.oft")

Actually stores inside the .Body property.

So, when you add the command .HTMLBody = "Test", you are overwriting your template!

I don't know what your template looks like, but if you are trying to tag some text after the template, try this:

Sub test2()
Dim myOlApp As Object
Dim MyItem As Object
Dim strBody As String

    Set myOlApp = CreateObject("Outlook.Application")
    Set MyItem = myOlApp.CreateItemFromTemplate("H:\FOLDER\Macros\Snapshot.oft")

    With MyItem
        .To = Sheets("Clients").Range("A1")
        .Subject = "Monthly bill"
        strBody = .Body
        .Body = strBody & vbCrLf & vbCrLf & "Test"
        'Refer to and fill in variable items in template
        .Display
    End With
    Set MyItem = Nothing
    Set myOlApp = Nothing
End Sub

Open in new window


If your Outlook template contains HTML, then I believe would need to combine the HTML from the template with the HTML from the rest of the body, then set that all at once in the .HTMLBody property.

Cheers,

Dave
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

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

Access It Now
 
imjayfrankAuthor Commented:
Thanks Dave. So I changed it to add the following:

strBody = .HTMLBody
.HTMLBody = strBody & vbCrLf & vbCrLf & "Testing 1 2 3"

As my template is HTML. However, what I want to do is not add text under it, but add text IN the template.

Example the template contains a header and footer with a grey box all around. I want to enter text in the middle (replacing the xxxx). Can you do this?

See attached, i had to blur out the company info.
Untitled-1.jpg
0
 
dlmilleCommented:
See this primary tip used for developing your solution:
http://msdn.microsoft.com/en-us/library/dd492012(v=office.12).aspx

Let's assume you want to replace the string "XXXTextToReplaceXXX".  Need to be unique enough with the parameter so you can find it and it doesn't confuse the HTML code as well. E.g., if you use a parameter like %TextToReplace% it will not find it as the HTML code generated from the .OFT file will interpret the % as something else.  I've tested this and saved the template as HTML so I assume that's what's going on with the OFT.  It took me a while (because I thought I was doing something wrong) to figure this out.  In the tip example it uses %Project_Type% so that's what I did in the template and no matter what I did, it would not find it.  I even created ReplyTo as in the tip example to no avail.  That's when I started to look at the bodyHTML that was being generated and it clued me in to this.

Ok - create your code with XXXTextToReplaceXXX in the template, and the code below will work.  I added the routine getNewHTML() to allow you to specify if you wanted your replacement text to be at the 1- beginning, 2- middle, or 3- end of the body.  Note the replacement text is optional and is not used in the function unless you choose the middle option.

I also created a little app, using ranges on the worksheet to specify the path to the OFT, the find and replacement string, and option of beginning, at keyword/middle, or end.  The routine used for that is called: SendEmailWTemplate()

Here's the code:

Option Explicit

Sub test2()
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("H:\FOLDER\Macros\Snapshot.oft")

    With MyItem
        .To = Sheets("Clients").Range("A1")
        .Subject = "Monthly bill"
        
        strNewText = "<p>this is a test</p>"

        '.HTMLBody = getNewHTML(.HTMLBody, strNewText, 1, vbNullString) 'test iAddOption = 0 @ beginning of body
        .HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX") 'test iAddOption = 1 @ replace search string in body
        '.HTMLBody = getNewHTML(.HTMLBody, strNewText, 3, vbNullString) 'test iAddOption = 2 @ end of body
        
        .Display
    End With
    Set MyItem = Nothing
    Set myOlApp = Nothing
End Sub
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


See attached.

Cheers,

Dave
sendEmailUsingTemplate-r2.xlsm
0
 
imjayfrankAuthor Commented:
Thanks Dave.

The code looks great.

One question, if I want to replace strNewText to equal a range, how can I do that?

it doesn't seem to like: strNewText = Cells.Range("a3:e60")

Also, if I want to add an additional field to replace? i.e. I added XXXDateXXX to the template which I want to replace with the current date.
0
 
imjayfrankAuthor Commented:
I figured out the date item.

All thats left is having strNewText as the range.

Thanks!
0
 
dlmilleCommented:
You can't assign a text field to an entire range.  If you want to concatenate those cells together, use ths:

dim vNewText as variant
dim i as long

vNewText = Cells.Range("A3:E60)

for i = lbound(vnewtext) to ubound(vnewtext)
  if strNewText = vbnullstring then
     strNewText = vnewtext(i)
  else
    strNewText = strNewText & vbcrlf & vnewtext(i)
  end if
next i

Open in new window

now, strNewText has the data.

>> Also, if I want to add an additional field to replace? i.e. I added XXXDateXXX to the template which I want to replace with the current date.

Go for it!  Just add the code to the case statement and repeat the statements at each case but with your next findString.

Any other questions?

Cheers,

Dave
0
 
imjayfrankAuthor Commented:
hmm. doesnt seem to be working right.

i dont.

what's wrong with this?

Sub LightningBolt1_Click()
Dim myOlApp As Object
Dim MyItem As Object
Dim rangebody As Range
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:\file.oft")

With MyItem
.bcc = "Clients Names Here"
.cc = "cc here"
.Subject = "subject here"
strBody = .HTMLBody
'Set rangebody = Cells.Range("a3:e60")
'strNewText = "<p>this is a test</p>"
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")
.Display
End With
Set MyItem = Nothing
Set myOlApp = Nothing

End Sub

Open in new window

0
 
dlmilleCommented:
.HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX")  'Assume this one works.

Let's try this.

strNewText =.HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX")
strNewText = .HTMLBody = getNewHTML(.HTMLBody, strNewText2, 2, "XXXDateXXX")

Now in each line, you can examine strNewText to make sure the changes happend in the first, then the second instance.  Do a instr to test that XXXTextToReplaceXXX exists before the first statement, and that it doesnt and your substitution (or part of it does)

Then do the same on the second.

Finally, add the line:

.HTMLBody = strNewText

PS - why did you comment out line 29?

Dave
0
 
imjayfrankAuthor Commented:
let me try now.

line 29 was a typo, i didnt comment it out.
0
 
imjayfrankAuthor Commented:
says this subscript out of range:
strNewText = vNewText(i)

The strnewtext and strnewtext2 worked fine as expected until I tried to have strNewtext be the range.

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

0
 
imjayfrankAuthor Commented:
same error even when i change .html body to:

strNewText = .HTMLBody = getNewHTML(.HTMLBody, strNewText, 2, "XXXTextToReplaceXXX") 'test iAddOption = 1 @ replace search string in body
strNewText = .HTMLBody = getNewHTML(.HTMLBody, strNewText2, 2, "XXXDateXXX")
.HTMLBody = strNewText

Open in new window


subscript out of range:
    strNewText = vNewText(i)
0
 
dlmilleCommented:
Also, that's a large range to be sending the way I teed it up to you.  Let's scrap that.

What you need is a range to HTML function.  Here's a link to Ron deBruin's and I was playing with that on another project, yesterday:
http://www.rondebruin.nl/mail/folder3/mail4.htm

Add that function and use it to convert the range to HTML then do your getHTML function to do replacements.

Dave
0
 
dlmilleCommented:
PS - the code I gave you for variant = range won't work for the range you've selected, it works for a one dimensional range.  We don't need it anyway, the RangeToHTML should give you a good representation of what the worksheet looks like.  There's also a way to copy and paste it in as a picture and if we need that, I can dig up a link to a past solution that has that approach.

Dave
0
 
imjayfrankAuthor Commented:
i added the function, your right in that it doesnt work right with the range now.

i tried your last code change and it bring up the email with the range but not the template.

I don't need to copy and paste as a picture, just want to get the data in the template.

how can i do it?
0
 
imjayfrankAuthor Commented:
snippet
'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

Open in new window

0
 
dlmilleCommented:
Its working for me with a top and bottom picture and two replacement strings in the middle - see my template, attached and try the Excel file I uploaded for testing.  

Then, with your setup, make sure your replacement text strings exist, open your template and validate.


See attached,

DOWNLOAD the template then RENAME extension to .OFT

Cheers,

Dave
Test-HTML--2-.zip
0
 
imjayfrankAuthor Commented:
i tested with your .oft and it pastes the range but no template.

did you look at my code? am i doing something different?
0
 
imjayfrankAuthor Commented:
disregard. i got it!

i had to comment out: .HTMLBody = strNewText


thanks again dave!
0
 
imjayfrankAuthor Commented:
Great answer, great person, great to deal with!
0
 
dlmilleCommented:
Thanks for your kind words.  You know, I'd never had to work with MS Outlook templates nor modifying HTML against a template. It took some digging and couldn't find anyone who'd used a template, then did string replacement in the HTML at the same time - so it was really new development for me rather than adapting something that already existed (albeit, not from scratch).

So, thanks for that question as I enjoyed working with you and the overall experience as well!

Dave
0
 
imjayfrankAuthor Commented:
hey dave,
"There's also a way to copy and paste it in as a picture and if we need that, I can dig up a link to a past solution that has that approach."

can you pass that along please? I want to try that  and see if my sheet comes out better if as an image.
0
 
imjayfrankAuthor Commented:
hey dave,
"There's also a way to copy and paste it in as a picture and if we need that, I can dig up a link to a past solution that has that approach."

can you pass that along please? I want to try that  and see if my sheet comes out better if as an image.
0
 
dlmilleCommented:
I thought I did respond to your last question.  Sorry about that - the website and I (one of "us" anyway) went bonkers :)

Here's the link to past solution where I crafted a modified RangeToHTML2() routine.  The HTML would need to be merged to whatever you already have:

http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Objects/Q_27563263.html

Here's code I believe Ron deBruin authored, which uses the publishObjects approach:

Public Function RangetoHTML2()
' You can't use this function in Excel 97
Dim fso As Object
Dim ts As Object
Dim TempFile As String

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    With ActiveWorkbook.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=ActiveSheet.Name, _
         Source:=ActiveSheet.UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML2 = ts.ReadAll
    ts.Close
    Set ts = Nothing
    Set fso = Nothing
    Kill TempFile
End Function

Open in new window


The code posted might be more flexible than my copy to GIF then import into HTML approach in my modified RangeToHTML2 approach.  The function needs to be modified so you can pass it the range rather than using the activesheet's used range.

Cheers,

Dave
0
 
imjayfrankAuthor Commented:
cheers!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.