rogerdjr
asked on
Sending an Email from Excel
I have a procedure I used about two years agoo (prior to upgrading to Office 2010) that would automatically send emails.
For some reason it is not working with Office 2010 and is not giving any error messages.
I made sure that references are updated for the spreadsheet.
Anybody have a suggestion?
Sub SendDocAsMsg()
Dim itmMail As Outlook.MailItem
Dim WordObj As Object
Dim MinutesOrAgenda As Integer, WkDt As Date
Dim WrdFileNm As String
Dim a08012 As String, a08250 As String, aGeneral As String
Dim PathNm As String, PathLen As Integer
Dim WaitTm As Integer
Dim MoTxt As String, DayTxt As String
'========================= ========== ========== ========== =====
Dim wd As Word.Application
Dim doc As Word.Document
Dim itm As Object
Dim ID As String
Dim blnWeOpenedWord As Boolean
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Applica tion")
blnWeOpenedWord = True
End If
wd.Documents.Add Template:="SubmittalBlankS heet", NewTemplate:=False, DocumentType:=0
wd.ActiveDocument.SaveAs ("C:\0\testblank.doc")
wd.Documents.Open ("C:\0\testblank.doc")
Sheets("Email Text").Select
Range("B7").Select
If Cells(7, 8).Value = "Pending WRD Rvw" Then
Range("A1:B12").Copy
Else
Range("h1:i10").Copy
End If
With wd.Selection
.Paste
End With
Application.CutCopyMode = False
wd.ActiveDocument.SaveAs ("C:\0\test.doc")
wd.Documents.Close (SaveChanges)
Set doc = wd.Documents.Open(FileName :="C:\0\te st.doc", ReadOnly:=True)
Set itm = doc.MailEnvelope.Item
'========================= ========== ========== ========== ====
Dim x As Integer, EmailAdrCC As String, EmailAdr As String, Subj As String, FileNm As String
x = 2
While x < 1000
Range(Cells(x, 19), Cells(x, 19)).Select
If Cells(x, 22).Value = "s" Then
Subj = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "p" Then
PathNm = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "f" Then
FileNm = Cells(x, 23).Value
End If
If Len(Cells(x, 20).Value) > 0 Then
If Len(EmailAdr) = 0 Then
EmailAdr = Cells(x, 20).Value
Else
EmailAdr = EmailAdr & "; " & Cells(x, 20).Value
End If
End If
If Len(Cells(x, 21).Value) > 0 Then
If Len(EmailAdrCC) = 0 Then
EmailAdrCC = Cells(x, 21).Value
Else
EmailAdrCC = EmailAdrCC & "; " & Cells(x, 21).Value
End If
End If
x = x + 1
Wend
Range("A1").Select
'========================= ========== ========== ========== ====
'MsgBox EmailAdr & vbNewLine & EmailAdrCC
With itm
.To = EmailAdr
.CC = EmailAdrCC
.Subject = Subj
.Save
ID = .EntryID
End With
Set itm = Nothing
Set itm = Application.Session.GetIte mFromID(ID )
itm.Save
'itm.Send
doc.Close wdDoNotSaveChanges
If blnWeOpenedWord Then
wd.Quit
End If
Set doc = Nothing
Set itm = Nothing
Set wd = Nothing
'========================= ========== ========== ========== ====
Dim objOL As Object
Dim myItems As Outlook.Items
Dim myitem As MailItem
Set objOL = CreateObject("Outlook.Appl ication")
Set myOlApp = CreateObject("Outlook.Appl ication")
Set myNamespace = myOlApp.GetNamespace("MAPI ")
Set myFolder = myNamespace.GetDefaultFold er(olFolde rDrafts)
Dim ID1 As String
y = 1
While y < 1000
Set myitem = myFolder.Items(y)
ID1 = myitem.EntryID
If ID1 = ID Then
myitem.Display
End If
y = y + 1
Wend
End Sub
12808.100-Quail-Lodge---Lodge-Me.xlsm
For some reason it is not working with Office 2010 and is not giving any error messages.
I made sure that references are updated for the spreadsheet.
Anybody have a suggestion?
Sub SendDocAsMsg()
Dim itmMail As Outlook.MailItem
Dim WordObj As Object
Dim MinutesOrAgenda As Integer, WkDt As Date
Dim WrdFileNm As String
Dim a08012 As String, a08250 As String, aGeneral As String
Dim PathNm As String, PathLen As Integer
Dim WaitTm As Integer
Dim MoTxt As String, DayTxt As String
'=========================
Dim wd As Word.Application
Dim doc As Word.Document
Dim itm As Object
Dim ID As String
Dim blnWeOpenedWord As Boolean
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Applica
blnWeOpenedWord = True
End If
wd.Documents.Add Template:="SubmittalBlankS
wd.ActiveDocument.SaveAs ("C:\0\testblank.doc")
wd.Documents.Open ("C:\0\testblank.doc")
Sheets("Email Text").Select
Range("B7").Select
If Cells(7, 8).Value = "Pending WRD Rvw" Then
Range("A1:B12").Copy
Else
Range("h1:i10").Copy
End If
With wd.Selection
.Paste
End With
Application.CutCopyMode = False
wd.ActiveDocument.SaveAs ("C:\0\test.doc")
wd.Documents.Close (SaveChanges)
Set doc = wd.Documents.Open(FileName
Set itm = doc.MailEnvelope.Item
'=========================
Dim x As Integer, EmailAdrCC As String, EmailAdr As String, Subj As String, FileNm As String
x = 2
While x < 1000
Range(Cells(x, 19), Cells(x, 19)).Select
If Cells(x, 22).Value = "s" Then
Subj = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "p" Then
PathNm = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "f" Then
FileNm = Cells(x, 23).Value
End If
If Len(Cells(x, 20).Value) > 0 Then
If Len(EmailAdr) = 0 Then
EmailAdr = Cells(x, 20).Value
Else
EmailAdr = EmailAdr & "; " & Cells(x, 20).Value
End If
End If
If Len(Cells(x, 21).Value) > 0 Then
If Len(EmailAdrCC) = 0 Then
EmailAdrCC = Cells(x, 21).Value
Else
EmailAdrCC = EmailAdrCC & "; " & Cells(x, 21).Value
End If
End If
x = x + 1
Wend
Range("A1").Select
'=========================
'MsgBox EmailAdr & vbNewLine & EmailAdrCC
With itm
.To = EmailAdr
.CC = EmailAdrCC
.Subject = Subj
.Save
ID = .EntryID
End With
Set itm = Nothing
Set itm = Application.Session.GetIte
itm.Save
'itm.Send
doc.Close wdDoNotSaveChanges
If blnWeOpenedWord Then
wd.Quit
End If
Set doc = Nothing
Set itm = Nothing
Set wd = Nothing
'=========================
Dim objOL As Object
Dim myItems As Outlook.Items
Dim myitem As MailItem
Set objOL = CreateObject("Outlook.Appl
Set myOlApp = CreateObject("Outlook.Appl
Set myNamespace = myOlApp.GetNamespace("MAPI
Set myFolder = myNamespace.GetDefaultFold
Dim ID1 As String
y = 1
While y < 1000
Set myitem = myFolder.Items(y)
ID1 = myitem.EntryID
If ID1 = ID Then
myitem.Display
End If
y = y + 1
Wend
End Sub
12808.100-Quail-Lodge---Lodge-Me.xlsm
what is the sheet that trigers this macro ? as seems the macro is sitting there and not connected to any button or cell ! is it activated manually ? if yes then when you open what sheet and pls explain what you do step by step as seems it is a question of reference that is causing the trouble.
gowflow
gowflow
ASKER
on the "Email Text" sheet, there is a button that reads "Send Email" located at cell E-1
12808.100-Quail-Lodge---Lodge-Me.xlsm
12808.100-Quail-Lodge---Lodge-Me.xlsm
ok first of all lets start with the most obvious
open the file goto vba and on hte tool menu choose References. A window will open with a list of items that are ticked make sure non of them has the word MISSING before it. If it does then lokk in hte list if you find the item and tick on it press ok save the workbook close it run it again and check if this solves it. If not let me know then will look deeper in the code as you advised that it was working before.
gowflow
open the file goto vba and on hte tool menu choose References. A window will open with a list of items that are ticked make sure non of them has the word MISSING before it. If it does then lokk in hte list if you find the item and tick on it press ok save the workbook close it run it again and check if this solves it. If not let me know then will look deeper in the code as you advised that it was working before.
gowflow
ASKER
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
I get an error message - see attached
Error.jpg
Error.jpg
when u get this error press on debug and tell me what line is in yellow.
Make sure in tools/references all the libraries are ticked and no library has MISSING to start with.
gowflow
Make sure in tools/references all the libraries are ticked and no library has MISSING to start with.
gowflow
ASKER
Set doc = wd.Documents.Open(FileName :="C:\0\te st.doc", ReadOnly:=True)
well make sure the library reference for Word is activated. Microsoft Word 14.0 should be ticked.
Make sure directory C:\0 is created on your C drive.
gowflow
Make sure directory C:\0 is created on your C drive.
gowflow
ASKER
The last "tweek" was to change from a .doc suffix to a .docx suffix - now it works like a charm
Sub SendDocAsMsg()
Dim itmMail As Outlook.MailItem
Dim WordObj As Object
Dim MinutesOrAgenda As Integer, WkDt As Date
Dim WrdFileNm As String
Dim a08012 As String, a08250 As String, aGeneral As String
Dim PathNm As String, PathLen As Integer
Dim WaitTm As Integer
Dim MoTxt As String, DayTxt As String
'========================= ========== ========== ========== =====
Dim wd As Word.Application
Dim doc As Word.Document
Dim itm As Object
Dim ID As String
Dim blnWeOpenedWord As Boolean
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Applica tion")
blnWeOpenedWord = True
End If
On Error GoTo 0
wd.Documents.Add NewTemplate:=False, DocumentType:=0
'wd.Documents.Add Template:="SubmittalBlankS heet", NewTemplate:=False, DocumentType:=0
wd.ActiveDocument.SaveAs ("C:\0\testblank.docx")
wd.Documents.Open ("C:\0\testblank.docx")
Sheets("Email Text").Select
Range("B7").Select
If Cells(7, 8).Value = "Pending WRD Rvw" Then
Range("A1:B12").Copy
Else
Range("h1:i10").Copy
End If
With wd.Selection
.Paste
End With
Application.CutCopyMode = False
wd.ActiveDocument.SaveAs ("C:\0\test.docx")
wd.Documents.Close (SaveChanges)
Set doc = wd.Documents.Open(FileName :="C:\0\te st.docx", ReadOnly:=True)
Set itm = doc.MailEnvelope.Item
'========================= ========== ========== ========== ====
Dim x As Integer, EmailAdrCC As String, EmailAdr As String, Subj As String, FileNm As String
x = 2
While x < 1000
Range(Cells(x, 19), Cells(x, 19)).Select
If Cells(x, 22).Value = "s" Then
Subj = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "p" Then
PathNm = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "f" Then
FileNm = Cells(x, 23).Value
End If
If Len(Cells(x, 20).Value) > 0 Then
If Len(EmailAdr) = 0 Then
EmailAdr = Cells(x, 20).Value
Else
EmailAdr = EmailAdr & "; " & Cells(x, 20).Value
End If
End If
If Len(Cells(x, 21).Value) > 0 Then
If Len(EmailAdrCC) = 0 Then
EmailAdrCC = Cells(x, 21).Value
Else
EmailAdrCC = EmailAdrCC & "; " & Cells(x, 21).Value
End If
End If
x = x + 1
Wend
Range("A1").Select
'========================= ========== ========== ========== ====
'MsgBox EmailAdr & vbNewLine & EmailAdrCC
With itm
.To = EmailAdr
.CC = EmailAdrCC
.Subject = Subj
.Save
ID = .EntryID
End With
Set itm = Nothing
'Set itm = Application.Session.GetIte mFromID(ID )
'itm.Save
'itm.Send
doc.Close wdDoNotSaveChanges
If blnWeOpenedWord Then
wd.Quit
End If
Set doc = Nothing
Set itm = Nothing
Set wd = Nothing
'========================= ========== ========== ========== ====
Dim objOL As Object
Dim myItems As Outlook.Items
Dim myNamespace As Outlook.Namespace
Dim myitem As MailItem
Set objOL = CreateObject("Outlook.Appl ication")
Set myOlApp = CreateObject("Outlook.Appl ication")
Set myNamespace = myOlApp.GetNamespace("MAPI ")
Set myFolder = myNamespace.GetDefaultFold er(olFolde rDrafts)
Dim ID1 As String
y = 1
Do While y < 1000
Set myitem = myFolder.Items(y)
ID1 = myitem.EntryID
If ID1 = ID Then
myitem.Display
Exit Do
End If
y = y + 1
Loop
End Sub
Sub SendDocAsMsg()
Dim itmMail As Outlook.MailItem
Dim WordObj As Object
Dim MinutesOrAgenda As Integer, WkDt As Date
Dim WrdFileNm As String
Dim a08012 As String, a08250 As String, aGeneral As String
Dim PathNm As String, PathLen As Integer
Dim WaitTm As Integer
Dim MoTxt As String, DayTxt As String
'=========================
Dim wd As Word.Application
Dim doc As Word.Document
Dim itm As Object
Dim ID As String
Dim blnWeOpenedWord As Boolean
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Applica
blnWeOpenedWord = True
End If
On Error GoTo 0
wd.Documents.Add NewTemplate:=False, DocumentType:=0
'wd.Documents.Add Template:="SubmittalBlankS
wd.ActiveDocument.SaveAs ("C:\0\testblank.docx")
wd.Documents.Open ("C:\0\testblank.docx")
Sheets("Email Text").Select
Range("B7").Select
If Cells(7, 8).Value = "Pending WRD Rvw" Then
Range("A1:B12").Copy
Else
Range("h1:i10").Copy
End If
With wd.Selection
.Paste
End With
Application.CutCopyMode = False
wd.ActiveDocument.SaveAs ("C:\0\test.docx")
wd.Documents.Close (SaveChanges)
Set doc = wd.Documents.Open(FileName
Set itm = doc.MailEnvelope.Item
'=========================
Dim x As Integer, EmailAdrCC As String, EmailAdr As String, Subj As String, FileNm As String
x = 2
While x < 1000
Range(Cells(x, 19), Cells(x, 19)).Select
If Cells(x, 22).Value = "s" Then
Subj = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "p" Then
PathNm = Cells(x, 23).Value
ElseIf Cells(x, 22).Value = "f" Then
FileNm = Cells(x, 23).Value
End If
If Len(Cells(x, 20).Value) > 0 Then
If Len(EmailAdr) = 0 Then
EmailAdr = Cells(x, 20).Value
Else
EmailAdr = EmailAdr & "; " & Cells(x, 20).Value
End If
End If
If Len(Cells(x, 21).Value) > 0 Then
If Len(EmailAdrCC) = 0 Then
EmailAdrCC = Cells(x, 21).Value
Else
EmailAdrCC = EmailAdrCC & "; " & Cells(x, 21).Value
End If
End If
x = x + 1
Wend
Range("A1").Select
'=========================
'MsgBox EmailAdr & vbNewLine & EmailAdrCC
With itm
.To = EmailAdr
.CC = EmailAdrCC
.Subject = Subj
.Save
ID = .EntryID
End With
Set itm = Nothing
'Set itm = Application.Session.GetIte
'itm.Save
'itm.Send
doc.Close wdDoNotSaveChanges
If blnWeOpenedWord Then
wd.Quit
End If
Set doc = Nothing
Set itm = Nothing
Set wd = Nothing
'=========================
Dim objOL As Object
Dim myItems As Outlook.Items
Dim myNamespace As Outlook.Namespace
Dim myitem As MailItem
Set objOL = CreateObject("Outlook.Appl
Set myOlApp = CreateObject("Outlook.Appl
Set myNamespace = myOlApp.GetNamespace("MAPI
Set myFolder = myNamespace.GetDefaultFold
Dim ID1 As String
y = 1
Do While y < 1000
Set myitem = myFolder.Items(y)
ID1 = myitem.EntryID
If ID1 = ID Then
myitem.Display
Exit Do
End If
y = y + 1
Loop
End Sub
yes correct !!! glad you were able to fix it as it worked perfectly here maybe due to the fact I hv word 2003 and 2007 !!! Congrat !!!
gowflow
gowflow
I have a similar spreadsheet that I have a Sheet with the To/CC/From email addresses and text to add to email body, I also convert selected cells to HTML in the email too. Works a treat!