Hello! So I have a problem.......its almost painful to explain b/c
i'm
just confused!

I've had this macro that worked for a few months. I came into today
and it doesn't work.....


When I use this code:


Set itm = doc.MailEnvelope.Item


I get this e0rror:
Run-Time error '-2147467259. Method 'Mailenvelope' of object_document
failed


So I tried to change the code to:
Set OutApp = CreateObject("Outlook.Application")


Error: Run time error '429' ActiveX Component can't create object.


My only explanation is that the help desk used the following updates:


http://www.microsoft.com/technet/sec.../MS07-002.mspx
http://www.microsoft.com/technet/sec.../MS07-003.mspx
http://support.microsoft.com/kb/919029
http://www.microsoft.com/technet/sec.../MS07-014.mspx
http://www.Microsoft.com/technet/sec.../MS07-015.mspx


Here is my code in whole....I have no idea whats going on. Any help
would be greatly appreciated!


Sub newtest()


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\WEEKLY MARKET UPDATE
SUMMARY.doc ", ReadOnly:=True)


Set itm = doc.MailEnvelope.Item
doc.MailEnvelope.Introduction = ActiveCell.Offset(0, 4).Value
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
.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