Macro that loses formatting

[Marlene.Sawhney]

Hello Everyone,

I have the following macro that runs in excel and produces an email in
outlook 2000. Generally the way it works is that it fills out the to,
cc and subject fields, attaches 1 or 2 documents and then also creates
the body of the text. I would like a portion of the body of the text
to be italicized. The body of the text is in column E.

However, when the macro runs and goes into outlook the italicize is
gone. Any suggestion on what I should do so that the italicize goes
into outlook? I'm assuming the problem is in this :

doc.MailEnvelope.Introduction = ActiveCell.Offset(0, 4).Text

Thank you in advance!!!!!

Sub JY_Marco()

Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim olMyApp As Outlook.Application
Dim olMyEmail As Outlook.mailItem


Dim wd As Word.Application
Dim doc As Word.Document
Dim itm As Object
Dim ID As String
Dim body As String
Dim blnWeOpenedWord As Boolean
'On Error Resume Next

'Initialize Word
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
blnWeOpenedWord = True
End If

'Initialize Workbook
Set wkb = ThisWorkbook
Set wks = wkb.Worksheets("Sheet1")
Set rng = wks.Range("A2")

'Initialize Outlook
Set olMyApp = New Outlook.Application
Set olMyEmail = olMyApp.CreateItem(olMailItem)

'Start Range at Cell A2
Range("A2").Select

'Loop through all rows in spreadsheet
Do Until IsEmpty(ActiveCell)
Set doc = wd.Documents.Open _
(Filename:="\\ntdisk01\dcm\Staff\Mar-Star\Macro versions\NY\JY
\WEEKLY MARKET UPDATE SUMMARY.doc ", ReadOnly:=True)


'Set doc = wd.Documents.Open(CStr(ActiveCell.Offset(0,
2).Hyperlinks.Item(1).Address))


Set itm = doc.MailEnvelope.Item
doc.MailEnvelope.Introduction = ActiveCell.Offset(0, 4).Text
With itm
.To = ActiveCell.Text
.CC = ActiveCell.Offset(0, 5).Text
.Subject = ActiveCell.Offset(0, 1).Text
.Attachments.Add (CStr(ActiveCell.Offset(0, 3).Value))
If Len(Trim(ActiveCell.Offset(0, 6).Value)) > 0 Then
.Attachments.Add CStr(ActiveCell.Offset(0, 6).Value)
End If
If Len(Trim(ActiveCell.Offset(0, 7).Value)) > 0 Then
.Attachments.Add CStr(ActiveCell.Offset(0, 7).Value)
End If
.Save
End With
Set itm = Nothing
doc.Close wdDoNotSaveChanges
If blnWeOpenedWord Then
wd.Quit
End If
ActiveCell.Offset(1, 0).Select
Loop


MsgBox "You successfully sent the email & attachment to your
drafts folder."


Set olMyApp = Nothing
Set olMyEmail = Nothing
Set doc = Nothing
Set itm = Nothing
Set wd = Nothing

End Sub

THANKS AGAIN!