Solved

Sending an Email from Excel

Posted on 2013-01-09
12
263 Views
Last Modified: 2013-01-11
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
0
Comment
Question by:rogerdjr
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 5
12 Comments
 
LVL 9

Expert Comment

by:TazDevil1674
ID: 38759946
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!
0
 
LVL 31

Expert Comment

by:gowflow
ID: 38762475
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
0
 

Author Comment

by:rogerdjr
ID: 38762983
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
0
Office 365 Training for Admins - 7 Day Trial

Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies.  Only from Platform Scholar.

 
LVL 31

Expert Comment

by:gowflow
ID: 38764343
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
0
 

Author Comment

by:rogerdjr
ID: 38767108
All references are working

See attached
References.jpg
0
 
LVL 31

Accepted Solution

by:
gowflow earned 500 total points
ID: 38767675
ok fine try this version and let me know.
gowflow


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.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
7    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

Open in new window



I would suggest you rename your current Sub to SendDocAsMsgMine and copy this one to your same module after any End Sub.

Let me know.
gowflow
0
 

Author Comment

by:rogerdjr
ID: 38768555
I get an error message - see attached
Error.jpg
0
 
LVL 31

Expert Comment

by:gowflow
ID: 38768566
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
0
 

Author Comment

by:rogerdjr
ID: 38768607
Set doc = wd.Documents.Open(FileName:="C:\0\test.doc", ReadOnly:=True)
0
 
LVL 31

Expert Comment

by:gowflow
ID: 38768766
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
0
 

Author Comment

by:rogerdjr
ID: 38769255
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
0
 
LVL 31

Expert Comment

by:gowflow
ID: 38769509
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
0

Featured Post

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
In this article I discuss my selections of the Top Four free Outlook OST File Viewers available. Open, view and read even damaged OST files by using these tools. They all provide a clear preview of all data such as emails, notes, tasks, calendars, e…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…

626 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question