Hi Guys,
I have the routine below set up to take a worksheet, and use the worksheet as the body of an email. The email needs to include a header image in the body, the routine below works perfectly in excel / outlook 2000, but in 2003 the email has the image attached but the body just shows the IE missing image indicator.
Can anyone tell me whats wrong?
Any help would be fantastic thanks.
SY
I have the routine below set up to take a worksheet, and use the worksheet as the body of an email. The email needs to include a header image in the body, the routine below works perfectly in excel / outlook 2000, but in 2003 the email has the image attached but the body just shows the IE missing image indicator.
Can anyone tell me whats wrong?
Code:
Public Function SheetToHTML(sh As Worksheet)
Dim TempFile As String
Dim Nwb As Workbook
Dim fso As Object
Dim ts As Object
sh.Copy
Set Nwb = ActiveWorkbook
With Nwb.Sheets(1)
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
End Function
Public Sub EMail()
' Outlook objects
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim colAttach As Outlook.Attachments
Dim l_Attach As Outlook.Attachment
Dim oSession As MAPI.Session
' CDO objects
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment
Dim colFields As MAPI.Fields
Dim oField As MAPI.Field
Dim done, current, temp, addresses
Dim strEntryID As String
' Delete excess Rows
Rows("1:3").Select
Selection.Delete Shift:=xlUp
' create new Outlook MailItem
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
' add graphic as attachment to Outlook message
' change path to graphic as needed
Set colAttach = OutMail.Attachments
Set l_Attach = colAttach.Add("\\Other\OP-GDC.gif")
OutMail.Close olSave
strEntryID = OutMail.EntryID
Set OutMail = Nothing
' *** POSITION CRITICAL *** you must dereference the
' attachment objects before changing their properties
' via CDO
Set colAttach = Nothing
Set l_Attach = Nothing
' initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
' get the message created earlier
Set oMsg = oSession.GetMessage(strEntryID)
' set properties of the attached graphic that make
' it embedded and give it an ID for use in an <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(1)
Set colFields = oAttach.Fields
Set oField = colFields.Add(CdoPR_ATTACH_MIME_TAG, "image/gif")
Set oField = colFields.Add(&H3712001E, "myident")
oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
oMsg.Update
current = 1
done = False
temp = ""
addresses = ""
Do
temp = Worksheets(2).Range("a" & current).Value
If (temp = "") Then
done = True
Else: addresses = addresses & ";" & temp
End If
current = current + 1
Loop Until done = True
' get the Outlook MailItem again
Set OutMail = OutApp.GetNamespace("MAPI").GetItemFromID(strEntryID)
' add HTML content -- the <IMG> tag
With OutMail
.To = addresses
.CC = ""
.BCC = ""
.Subject = "Genesys Telephony Communication - " & Date
.HTMLBody = "<IMG align=baseline border=0 hspace=0 src=cid:myident>" & SheetToHTML(Sheets("Report"))
.Send 'or use .Display
End With
Application.ScreenUpdating = True
' clean up objects
Set oField = Nothing
Set colFields = Nothing
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
'Close workbook without saving
Application.DisplayAlerts = False
Application.Quit
End SubAny help would be fantastic thanks.
SY
