Excel Linked to Outlook not sending

S

StressTabz

New Member
Joined
Jul 1, 2015
Messages
22
Hi All,

I've created a an macro wherein it can multiple emails at the same time. I've asked my colleagues to use it and it works fine but some reason some of them aren't able to use it. What's happening is, the macro only created the email on outlook with all the correct data but you still to press send on outlook itself.

is this just a setting on outlook that needs to be adjusted since it works for me and so other people?
please advise
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
not everyone is having the issue thought, I do sometimes have the issue...

Worf said:
Can you post the complete code?
Click to expand...

Option Explicit
Dim olApp As Object
Dim olMail As Object
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim rRng As Range
Dim rColumn As Range
Sub SendMails()
'Disable screen updating
Application.ScreenUpdating = False
'Sort Report
Sheet02.Sort.SortFields.Clear
Sheet02.Sort.SortFields.Add Key:=Columns("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheet02.Sort
.SetRange Columns("A:K")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Check if Report exists
If Sheet02.Range("A2") = "" Then
MsgBox "There is no data in Report sheet!", vbCritical
End
End If
'Mail and name Formula
Sheet02.Activate
Range(Range("A1"), Range("A1").End(xlDown)).Offset(0, 10).Formula = "=IF(IFERROR(VLOOKUP(RC[-10],DataBase!C[-10]:C[-8],3,0),"""")=0,"""",IFERROR(VLOOKUP(RC[-10],DataBase!C[-10]:C[-8],3,0),""""))"
Range(Range("A1"), Range("A1").End(xlDown)).Offset(0, 11).Formula = "=IFERROR(VLOOKUP(RC[-11],DataBase!C[-11]:C[-9],2,0),"""")"
'Mail loop
Set rRng = Sheet02.Range("A2")
Do While rRng <> ""
If rRng <> rRng.Offset(-1, 0) And rRng.Offset(0, 10) <> "" Then
Sheet04.Activate
Range(Range("A1"), Range("A1").End(xlDown)).EntireRow.Delete
Call MailDraft
'Send Mails
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Sheet01.Activate
With olMail
.SentOnBehalfOfName = Range("E7").Value
.to = rRng.Offset(0, 10).Value
.CC = Range("E11").Value
.Subject = Range("E13").Value & " - " & rRng.Value & " " & rRng.Offset(0, 11).Value
.HTMLBody = RangetoHTML
.Display
End With
Set olMail = Nothing
Set olApp = Nothing
SendKeys "%{s}", True
Sheet02.AutoFilterMode = False
End If
Set rRng = rRng.Offset(1, 0)
Loop
'Clear previous draft
Sheet04.Cells.Delete
'Go back to main sheet
Sheet01.Activate
'Reset button comands
ActiveSheet.Shapes("Button 4").OnAction = "SendMails"
ActiveSheet.Shapes("Button 7").OnAction = "ClearReport"

'Enable screen updating
Application.ScreenUpdating = True
'Finish message
MsgBox "EMAIL/S HAS BEEN SENT!"
End Sub
Private Sub MailDraft()
'Clear previous draft
Sheet04.Cells.Delete
'Before invoice list
Sheet04.Activate
Range("A1").Formula = "=IF('E-mail'!R15C5="""","""",'E-mail'!R15C5)"
Range("A2").Formula = "=IF('E-mail'!R16C5="""","""",'E-mail'!R16C5)"
Range("A3").Formula = "=IF('E-mail'!R17C5="""","""",'E-mail'!R17C5)"
Range("A4").Formula = "=IF('E-mail'!R18C5="""","""",'E-mail'!R18C5)"
Range("A5").Formula = "=IF('E-mail'!R19C5="""","""",'E-mail'!R19C5)"
Range("A6").Formula = "=IF('E-mail'!R20C5="""","""",'E-mail'!R20C5)"
Range("A7").Formula = "=IF('E-mail'!R21C5="""","""",'E-mail'!R21C5)"

'Invoice list
Sheet02.Activate
Range(Range("A1:K1"), Range("A1:K1").End(xlDown)).AutoFilter Field:=1, Criteria1:=rRng.Value
Range(Range("A1:J1"), Range("A1:J1").End(xlDown)).SpecialCells(xlVisible).Copy Sheet04.Range("A8")
'After invoice list
'Add Row
Sheet04.Activate
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R23C5="""","""",'E-mail'!R23C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R24C5="""","""",'E-mail'!R24C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R25C5="""","""",'E-mail'!R25C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R26C5="""","""",'E-mail'!R26C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R27C5="""","""",'E-mail'!R27C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R28C5="""","""",'E-mail'!R28C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R29C5="""","""",'E-mail'!R29C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R30C5="""","""",'E-mail'!R30C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R31C5="""","""",'E-mail'!R31C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R32C5="""","""",'E-mail'!R32C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R33C5="""","""",'E-mail'!R33C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R34C5="""","""",'E-mail'!R34C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R35C5="""","""",'E-mail'!R35C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R36C5="""","""",'E-mail'!R36C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R37C5="""","""",'E-mail'!R37C5)"
Range("A1").End(xlDown).Offset(1, 0).Formula = "=IF('E-mail'!R38C5="""","""",'E-mail'!R38C5)"
'Autofit with minimun column width
Columns("B:J").EntireColumn.AutoFit
For Each rColumn In Columns("A:J")
If rColumn.ColumnWidth < 12 Then rColumn.ColumnWidth = 12
Next rColumn
End Sub
Private Function RangetoHTML()
'Define TempFile
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
Sheet04.Activate
Range(Range("A1:J1"), Range("A1:J1").End(xlDown)).Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=TempFile, Sheet:=TempWB.Sheets(1).Name, Source:=TempWB.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
'Reset objects
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 
Upvote 0
I don't have Outlook installed here at home, I will examine this at work next week...
 
Upvote 0
Please test this version that uses the Send method:

Code: 
Dim olApp As Object, olMail As Object, fso As Object, ts As Object
Dim TempFile$, TempWB As Workbook, rRng As Range, rColumn As Range

Sub SendMails()
Application.ScreenUpdating = False
Sheets("Sheet02").Sort.SortFields.Clear
Sheets("Sheet02").Sort.SortFields.Add Key:=Columns("A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=0
With Sheets("Sheet02").Sort
    .SetRange Columns("A:K")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'Check if Report exists
If Sheets("Sheet02").Range("A2") = "" Then
    MsgBox "There is no data in Report sheet!", vbCritical
    End
End If
'Mail and name Formula
Sheets("Sheet02").Activate
'Range(Range("A1"), Range("A1").End(xlDown)).Offset(0, 10).Formula = _
"=IF(IFERROR(VLOOKUP(RC[-10],DataBase!C[-10]:C[-8],3,0),"""")=0,"""",IFERROR(VLOOKUP(RC[-10],DataBase!C[-10]:C[-8],3,0),""""))"
Range(Range("A1"), Range("A1").End(xlDown)).Offset(0, 11).Formula = "=IFERROR(VLOOKUP(RC[-11],DataBase!C[-11]:C[-9],2,0),"""")"
Set rRng = Sheets("Sheet02").Range("A2")
Do While rRng <> ""
    If rRng <> rRng.Offset(-1, 0) And rRng.Offset(0, 10) <> "" Then
        Sheets("Sheet04").Activate
        Range(Range("A1"), Range("A1").End(xlDown)).EntireRow.Delete
        MailDraft
        Set olApp = CreateObject("Outlook.Application")
        Set olMail = olApp.CreateItem(olMailItem)
        Sheets("Sheet01").Activate
        With olMail
            .SentOnBehalfOfName = Range("E7")
            .to = rRng.Offset(0, 10)
            .CC = Range("E11").Value
            .Subject = Range("E13").Value & " - " & rRng.Value & " " & rRng.Offset(, 11)
            .HTMLBody = RangetoHTML
            .Display
        End With
        olMail.Send
        'SendKeys "%{e}", True
        Sheets("Sheet02").AutoFilterMode = False
    End If
    Set rRng = rRng.Offset(1)
Loop
'Clear previous draft
Sheets("Sheet04").Cells.Delete
'Go back to main sheet
Sheets("Sheet01").Activate
'Reset button comands
ActiveSheet.Shapes("Button 4").OnAction = "SendMails"
ActiveSheet.Shapes("Button 7").OnAction = "ClearReport"
Application.ScreenUpdating = True
MsgBox "EMAIL/S HAS BEEN SENT!", 64
Set olMail = Nothing
Set olApp = Nothing
End Sub

Private Sub MailDraft()
Sheets("Sheet04").Cells.Delete
'Before invoice list
Sheets("Sheet04").Activate
Range("A1").Formula = "=IF('E-mail'!R15C5="""","""",'E-mail'!R15C5)"
Range("A2").Formula = "=IF('E-mail'!R16C5="""","""",'E-mail'!R16C5)"
Range("A3").Formula = "=IF('E-mail'!R17C5="""","""",'E-mail'!R17C5)"
Range("A4").Formula = "=IF('E-mail'!R18C5="""","""",'E-mail'!R18C5)"
Range("A5").Formula = "=IF('E-mail'!R19C5="""","""",'E-mail'!R19C5)"
Range("A6").Formula = "=IF('E-mail'!R20C5="""","""",'E-mail'!R20C5)"
Range("A7").Formula = "=IF('E-mail'!R21C5="""","""",'E-mail'!R21C5)"
'Invoice list
Sheets("Sheet02").Activate
Range(Range("A1:K1"), Range("A1:K1").End(xlDown)).AutoFilter Field:=1, Criteria1:=rRng.Value
Range(Range("A1:J1"), Range("A1:J1").End(xlDown)).SpecialCells(xlVisible).Copy Sheets("Sheet04").Range("A8")
'After invoice list
'Add Row
Sheets("Sheet04").Activate
With Range("A1").End(xlDown).Offset(1)
    .Formula = "=IF('E-mail'!R23C5="""","""",'E-mail'!R23C5)"
    .Formula = "=IF('E-mail'!R24C5="""","""",'E-mail'!R24C5)"
    .Formula = "=IF('E-mail'!R25C5="""","""",'E-mail'!R25C5)"
    .Formula = "=IF('E-mail'!R26C5="""","""",'E-mail'!R26C5)"
    .Formula = "=IF('E-mail'!R27C5="""","""",'E-mail'!R27C5)"
    .Formula = "=IF('E-mail'!R28C5="""","""",'E-mail'!R28C5)"
    .Formula = "=IF('E-mail'!R29C5="""","""",'E-mail'!R29C5)"
    .Formula = "=IF('E-mail'!R30C5="""","""",'E-mail'!R30C5)"
    .Formula = "=IF('E-mail'!R31C5="""","""",'E-mail'!R31C5)"
    .Formula = "=IF('E-mail'!R32C5="""","""",'E-mail'!R32C5)"
    .Formula = "=IF('E-mail'!R33C5="""","""",'E-mail'!R33C5)"
    .Formula = "=IF('E-mail'!R34C5="""","""",'E-mail'!R34C5)"
    .Formula = "=IF('E-mail'!R35C5="""","""",'E-mail'!R35C5)"
    .Formula = "=IF('E-mail'!R36C5="""","""",'E-mail'!R36C5)"
    .Formula = "=IF('E-mail'!R37C5="""","""",'E-mail'!R37C5)"
    .Formula = "=IF('E-mail'!R38C5="""","""",'E-mail'!R38C5)"
End With
'Autofit with minimun column width
Columns("B:J").EntireColumn.AutoFit
For Each rColumn In Columns("A:J")
    If rColumn.ColumnWidth < 12 Then rColumn.ColumnWidth = 12
Next
End Sub

Private Function RangetoHTML()
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to paste the data in
Sheets("Sheet04").Activate
Range(Range("A1:J1"), Range("A1:J1").End(xlDown)).Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=TempFile, Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
    .Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
MS Excel VBA Meeting Request Code to Set Meeting to Property
Replies
4
Views
260
OilEconomist
O
C
  • Question Question
Opening Outlook to send and email
Replies
1
Views
379
Trebor76
T
JeffGrant
  • Solved
Excel talking to Outlook throws 462 errors
Replies
7
Views
288
JeffGrant
JeffGrant
F
  • Question Question
VBA Send a formatted mail without Outlook
Replies
4
Views
683
Forsberg
F
pcc
  • Question Question
Sending email prblem
Replies
2
Views
124
pcc
pcc

Forum statistics

Threads
1,223,237
Messages
6,170,928
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top