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

Maybe you can find something he

www.rondebruin.nl/sendmail.htm

" wrote:

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

try CDO
look it up in MS help site
http://www.rondebruin.nl/cdo.htm

you can send email with out an email client program running.
way cool end easy

--
Ray


wrote in message
ps.com...
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