sassriverrat
Well-known Member
- Joined
- Oct 4, 2018
- Messages
- 655
Hello,
I have a current piece of code that I use to email a pdf version of the active sheet in my open excel workbook. However, I run into two issues:
1. Outlook requires, with the PDF attachment, the user click a allow/deny dialog box because there's a potentially harmful attachment. If a user denies unknowingly, the report isn't sent.
2. Occasionally outlook doesn't actually send the email for maybe 30 minutes, maybe an hour (it's not consistent).
As such, I am trying to get around 1. Having to rely on the user actually hitting "allow" and the reliabilities of outlook. A friend suggested a piece of code below, but the IP address is a problem...I need the system to autodetect instead of manually inputting an IP.
Anyone have recommendations?
I have a current piece of code that I use to email a pdf version of the active sheet in my open excel workbook. However, I run into two issues:
1. Outlook requires, with the PDF attachment, the user click a allow/deny dialog box because there's a potentially harmful attachment. If a user denies unknowingly, the report isn't sent.
2. Occasionally outlook doesn't actually send the email for maybe 30 minutes, maybe an hour (it's not consistent).
As such, I am trying to get around 1. Having to rely on the user actually hitting "allow" and the reliabilities of outlook. A friend suggested a piece of code below, but the IP address is a problem...I need the system to autodetect instead of manually inputting an IP.
Anyone have recommendations?
VBA Code:
'Current active code
Public Sub Email_Active_Sheet()
Dim OutApp As Object, OutMail As Object
Dim emailSubject As String, bodyText As String, toEmailAddresses As String
Dim cell As Range, printRange As Range
Dim TempFileName As String
Dim name As String
name = Sheets("Notes").Range("N4")
'Sets parameters of email
With ThisWorkbook.Worksheets("Notes")
emailSubject = .Range("L45").Value
bodyText = .Range("L46").Value
toEmailAddresses = ""
For Each cell In .Range("L37:L43")
If cell.Value = "" Then
Exit Sub
Else: If cell.Value Like "?*@?*.?*" Then toEmailAddresses = toEmailAddresses & cell.Value & ";"
End If
Next
End With
'sets active sheet type (pdf)
With ThisWorkbook.ActiveSheet
TempFileName = Environ("temp") & "\" & .name & " Report " & Format(Now, "dd-mmm-yy") & ".pdf"
'Check Print Range
Call dailyprintarea
If .PageSetup.PrintArea = vbNullString Then
MsgBox (Environ("temp") & "\" & .name & " Report " & Format(Now, "dd-mmm-yy") & ".pdf")
MsgBox "You must first set the Print Area(s) on the '" & .name & "' sheet.", vbExclamation, name
Exit Sub
End If
'Continue with email piece
Set printRange = Range(.PageSetup.PrintArea)
printRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
'sets outlook to run
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'On Error Resume Next
With OutMail
.To = Left(toEmailAddresses, Len(toEmailAddresses) - 1)
.CC = ""
.BCC = ""
.Subject = emailSubject
.Body = bodyText
.Attachments.Add TempFileName
.Send
End With
'On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Kill TempFileName
End Sub
VBA Code:
'suggested new code
Sub cdo_mail()
Dim oEmail as Object
Set oEmail = CreateObject("CDO.Message")
With oEmail
.From = "chiefeng@santorini.osgship.com"
.To = "chiefeng@santorini.osgship.com"
.AddAttachment "C:\Users\ChiefEng\Desktop\acceptedtable.pdf"
.Subject = "E-Mail Subject"
.Textbody = "Here you are CodeMan...hope this helps" & _
vbNewLine & vbNewLine & "This is another line" & vbNewLine & _
vbNewLine & "Yep, aren't you happy?"
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "10.0.0.1"
'This is my issue line
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/authenticate") = 1
.Configuration.Fields.Update
.Send
End With
Set oEmail = Nothing
End Sub
Last edited by a moderator: