Solved

Sending an Email from Excel

Posted on 2013-01-09
12
251 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
  • 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 29

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
 
LVL 29

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 29

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
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

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

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 29

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 29

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

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

Resolve DNS query failed errors for Exchange
If you don't know how to downgrade, my instructions below should be helpful.
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

762 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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now