Solved

Sending an Email from Excel

Posted on 2013-01-09
12
259 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
VMware Disaster Recovery and Data Protection

In this expert guide, you’ll learn about the components of a Modern Data Center. You will use cases for the value-added capabilities of Veeam®, including combining backup and replication for VMware disaster recovery and using replication for data center migration.

 
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
 

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

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

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

Microsoft Office Picture Manager is not included in Office 2013. This comes as a shock to users upgrading from earlier versions of Office, such as 2007 and 2010, where Picture Manager was included as a standard application. This article explains how…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
CodeTwo Sync for iCloud (http://www.codetwo.com/sync-for-icloud?sts=6554) automatically synchronizes your Outlook 2016, 2013, 2010 or 2007 folders with iCloud folders available via iCloud Control Panel. This lets you automatically sync them with…

832 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