Link to home
Start Free TrialLog in
Avatar of rogerdjr
rogerdjrFlag for United States of America

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.Application")
        blnWeOpenedWord = True
    End If
   
    wd.Documents.Add Template:="SubmittalBlankSheet", 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\test.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.GetItemFromID(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.Application")
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
    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
Avatar of TazDevil1674
TazDevil1674
Flag of United Kingdom of Great Britain and Northern Ireland image

I would suggest checking this page http://www.rondebruin.nl/sendmail.htm

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!
Avatar of Jacques Geday
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
Avatar of rogerdjr

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
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
All references are working

See attached
References.jpg
ASKER CERTIFIED SOLUTION
Avatar of Jacques Geday
Jacques Geday
Flag of Canada image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
I get an error message - see attached
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
Set doc = wd.Documents.Open(FileName:="C:\0\test.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
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.Application")
        blnWeOpenedWord = True
    End If
    On Error GoTo 0
   
    wd.Documents.Add NewTemplate:=False, DocumentType:=0
    'wd.Documents.Add Template:="SubmittalBlankSheet", 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\test.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.GetItemFromID(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.Application")
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
    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