How do send a link to a document using word vba CDO email process? - vba

Does anybody know how to send a link to a word document via email in word vba? I want to use gmail not outlook. I found a solution for outlook:
http://www.rondebruin.nl/win/s1/outlook/bmail10.htm
Is there anyway that can be modified to work using gmail?
I modified: http://www.rondebruin.nl/win/s1/cdo.htm to work with gmail, and it is working fine. I just need to add a link to the body of the email.

You'll need to use the htmlBody property instead of TextBody and use an <a> tag in the HTML.

I didn't know how to send my code...So I posted it as an answer. Hope that's ok. Also I get a strange run time error that I wasn't getting before. Other than that it works.
Thanks!
Danielle
Option Explicit ' Modified for dSavage
'If you have a GMail account then you can try this example to use the GMail smtp server
'The example will send a small text message
'You must change four code lines before you can test the code
'.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Full GMail mail address"
'.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "GMail password"
'Use your own mail address to test the code in this line
'.To = "Mail address receiver"
'Change YourName to the From name you want to use
'.From = """YourName"" "
'If you get this error : The transport failed to connect to the server
'then try changing the SMTP port from 25 to 465
Sub CDO_Mail_Example()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim sAddForm As String
Dim sForm As String
Dim Flds As Variant
Dim iSMTP_Port As Integer
Dim sFirstReviewer As String
Dim sUserName As String
Dim sGmailPassword As String
sFirstReviewer = Range("F4").Value
sUserName = Range("F6").Value & "#indicate1.com"
sGmailPassword = Range("F8").Value
iSMTP_Port = Range("F10").Value '25 at Indicate; 465 away.
sAddForm = Range("I12").Value
'sForm = Range("F4").Value
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
If sAddForm = "Yes" Then
sForm = "Z:\Quality# # Document_Development# Documents_for_Review\12002-01-01 Company Handbook.doc"
Else
sForm = ""
End If
Debug.Print "sForm = " & sForm ' *******************************************
Debug.Print "sUserName = " & sUserName ' *******************************************
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sUserName
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Micro5cope"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = iSMTP_Port '25 at Indicate; 465 away.
.Update
End With
strbody = "To " & sFirstReviewer & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4" & vbNewLine & vbNewLine & vbNewLine & _
"Z:\Quality\# # Document_Development\# Documents_for_Review\12000-00-00 Tables 9-11 Template OLD - TEST.doc" & vbNewLine & _
sForm & vbNewLine
With iMsg
Set .Configuration = iConf
.To = sFirstReviewer & "#indicate1.com"
.CC = "" 'sUserName & "; " & "johanson111#comcast.net"
.BCC = ""
.From = sUserName
.Subject = "Test Message"
.textbody = strbody
.HtmlBody = "Google Page"
.AddAttachment "Z:\Quality\# # Document_Development\12001-02-01 Document Review Form.pdf"
.AddAttachment "Z:\Quality\# # Document_Development\12001-02 Document Review Draft 9.doc"
.Send
End With
Debug.Print "CC = " & sUserName ' *******************************************
End Sub

Related

How to pass email address and password for creating emails in GMail?

I need my Access Database to create emails that are sent at the press of a button.
This works for Outlook, and I adapted the code for Gmail.
I don't want to hardcode the email username and password. I want to pick it up from a combobox on the main form.
I get the error
Private Sub Email_Allocation_List_Click()
Dim newMail As CDO.Message
Dim mailConfiguration As CDO.Configuration
Dim fields As Variant
Dim msConfigURL As String
On Error GoTo errHandle
Set newMail = New CDO.Message
Set mailConfiguration = New CDO.Configuration
mailConfiguration.Load -1
Set fields = mailConfiguration.fields
With newMail
.Subject = "subject"
.From = [Forms]![Main form]![EmailAddress].Column(1)
.To = "email address"
.CC = "email address"
.BCC = ""
.TextBody = "Hello, " & vbNewLine & vbNewLine & _
"Please find attached todays list of lines to be allocated." & _
vbNewLine & vbNewLine & "Kind Regards." & vbNewLine & vbNewLine & "Carly"
.AddAttachment "file location"
End With
msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
With fields
.Item(msConfigURL & "/smtpusessl") = True
.Item(msConfigURL & "/smtpauthenticate") = 1
.Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2
.Item(msConfigURL & "/sendusername") = [Forms]![Main form]![EmailAddress].Column(1)
.Item(msConfigURL & "/sendpassword") = [Forms]![Main form]![EmailAddress].Column(2)
.Update
End With
newMail.Configuration = mailConfiguration
newMail.Send
MsgBox "E-Mail has been sent", vbInformation
exit_line:
'// Release object memory
Set newMail = Nothing
Set mailConfiguration = Nothing
Exit Sub
errHandle:
MsgBox "Error: " & Err.Description, vbInformation
GoTo exit_line
End Sub
I checked the comboboxes work with a text box.
After a lot of messing around, you are correct, the code is fine - and it was reading the contents of the combo box correctly - however GMail didn't accept the log in information if there was a capital letter on the email address!!! Now working beautifully.

VBA CDO Sending old image in email body

I'm using vba to send email using CDO (See below) it keeps pulling a old image from over 30 days ago for the email that it is sending out. Can anyone help?
Public Function sndmail(ByVal RecipientList As String, _
ByVal Subject As String, ByVal body As String, Optional ByVal Attachment As String, _
Optional ByVal cc As String)
Dim iMsg As Message
Dim iConf As Configuration
Dim strbody As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "SMTP.xx.xyz.COM"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
.Update
End With
With iMsg
Set .Configuration = iConf
.To = RecipientList
.cc = cc
.From = "chris#yoohoo.com"
.Subject = Subject
.HTMLBody = body
End With
iMsg.Send
End Function
...
imgfile = "C:\TEMP\FDW_Img.png"
imgfile2 = "C:\TEMP\FDW_DoD.png"
Set pp = New PowerPoint.Application
Set ppt = pp.Presentations.Open("C:\TEMP\bpp.pptx")
wbk1.Sheets("Summary by Modcode").Range("F22:Z28").Copy
ppt.Slides(1).Shapes.PasteSpecial (ppPasteBitmap)
ppt.Slides(1).Shapes(1).Export imgfile, ppShapeFormatPNG
ppt.Close
pp.Quit
DoEvents
'list of recipients
sndto = ""
'subject line for email
subj = "5 State Capital Finance Reports for " & Date
'body of email
bod = "Happy " & WeekdayName(Weekday(Date)) & "! <br>" & WeekdayName(Weekday(Date)) & "'s reports have been updated and can be found at the below links and snapshots can be found at the first weblink:<br><br>" & _
"<a href = a weblink here that currently works fine> Finance Website </a> <br>" & _
"<a href = another one here... works fine> Open vs Actuals </a> <br>" & _
"<a href = another one here... works fine> EE Report <a><br>" & _
"<a href = another one here... works fine> FDW Actuals <a>" & _
" <br> <br><img src='C:\Temp\FDW_img.png'><br><br>" & sig
'function to send email
sndmail sndto, subj, bod
Application.CutCopyMode = False
wbk1.Close False
This line is where it adds the image to the body of the email and it is adding an old image... the strange thing is that on the host pc if I pull up my email it shows correctly but on all other recipients or if I pull up my email on another pc it shows up with the old image.
" <br> <br><img src='C:\Temp\FDW_img.png'><br><br>" & sig

Runtime error if contact in Outlook doesn't exist

When I complete a piece of work I email it to certain people. It depends on the work who gets it.
If any person in the list leaves, changes job or has an email change the code will bug out saying
Run Time error -2147467259(80004005), Outlook Does Not Recognise One Or More Names
If I manually copy the email addresses in the list and pop them into Outlook and send I'll get an email back saying the user doesn't exist or has been changed.
I have tried On Error Resume Next and On Error Goto. I have added MS Outlook 14.0 Object Libary, SharePoint Social Provider, Social Provider Extensibility and Outlook View control from the references.
The code bugs out on the .send
Sub EMailer()
Application.ScreenUpdating = False
strfilepath = "\\DFZ70069\Data\199711009\workgroup\Res Plan Team\Performance Management\Specialised Reporting\Debit & Credit Reporting\Masters\Sent Reports\"
strArea = "Recipients" '..........................................................................................
'Get list of recipients for email
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value = "" Then GoTo Continue
strmaillist = strmaillist & cell.Value + ";"
Continue:
Next
[B1].Value = strmaillist
If bMyEmail = True Then
strmaillist = strmaillist & MyEmailAddress
End If
'Display email list
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Sending " & sReportName & " emails to " & vbNewLine & strArea, _
AckTime, "Message Box", 0)
Case 1, -1
End Select
'SEND EMAIL
'set up Body of email............
strbody = "Please find attached " & sReportName & " Report " & " _" & strDate & vbLf & vbLf & _
strComments & vbLf & _
strComments2 & vbLf & _
"" & vbLf & _
eMailName & vbLf & _
"MI & Performance Reporting Team" & vbLf & _
sline2 & vbLf & _
sline3 & vbLf & vbLf & _
sLine4
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = strmaillist
.CC = ""
.BCC = ""
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
.send ' bugs out here
End With
Set OutMail = Nothing
Set OutApp = Nothing
ThisWorkbook.Activate
Sheets("Sheet1").Select
Application.ScreenUpdating = True: Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range(sRange2).Value = sConclusion '.
Application.ScreenUpdating = True: Application.ScreenUpdating = False
End Sub
You can try to check the validity of the recipient before sending, by using the .Resolve method of the Recipient object. Only valid recipients can be kept in the Recipient list of the mail item.
You might try this:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value <> "" Then
set r = .Recipients.Add(cell.value)
If Not r.Resolve then r.Delete '<~~ Removes invalid recipients
End If
Next
.send
End With

How can I Include additional code to then send email via Vba through Gmail?

I have seen similar questions but mine is quite specific let me explain.
I have this code that runs from a button if clicked it prints the active sheet as a pdf to the same pathway as my workbook, this works as it should as the active sheet information changes via a list to present each customer info for each financial period.
Each month i then need to attach each of these pdf files to emails and send to customers which is a long winded process, if i input the email to appear in a cell eg ("E1") automatically when the customer is selected can i then adapt my code to open an email and send the pdf to that email address?
Sub PDFActiveSheet()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
On Error GoTo errHandler
Set ws = ActiveSheet
'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(Range("B1"), "", ""), "", "") _
& " Period " _
& Format(Now(), Cells.Range("J1")) _
& ".pdf"
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
ws.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
You can automate email sending through Outlook, but it seems like accessing Gmail and sending mail through the web would be a whole different ballpark. Gmail does have an API, which you can get documentation for here: https://developers.google.com/gmail/api/.
My suggestion is to setup Outlook with your Gmail account and then send through that, which is more likely way easier.
From Ron DeBruins website I found this and tested successfully. I did have to enable "All less secure apps" in my gmail settings. Here's the code in case his site ever goes down.
Sub CDO_Mail_Small_Text_2()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Your gmail address"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "gmail pw"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
Set .Configuration = iConf
.To = ""
.CC = ""
.BCC = ""
' Note: The reply address is not working if you use this Gmail example
' It will use your Gmail address automatic. But you can add this line
' to change the reply address .ReplyTo = "Reply#something.nl"
.From = """FROM??"" <Reply#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
End Sub

vba + Selection.Paste into outlook + control poition

What I am trying to do is copy a chart from excel into an outlook email, but after numerous searching I am struggling.
i am having trouble positioning where the chart is pasted. I want it to paste after the last line "this is another line again " in the body of the email. It currently pastes at the start of the email before the line "test ... body"
Sub CopyAndPasteToMailBody3() ' this works but how do i control where it puts the chart?
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(olMailItem)
mail.Display
mail.To = "A#a.com"
mail.subject = "subject" & Now
mail.body = "test ... body" & vbNewLine & vbNewLine _
& "this is another line " & vbCrLf _
& "this is another line again "
Set wEditor = mailApp.ActiveInspector.wordEditor
ActiveChart.ChartArea.Copy ' chart needs to be active
wEditor.Application.Selection.Paste
' mail.send
End Sub
Note: using excel 10 on windows 7
I have found that
Set wEditor = mailapp.ActiveInspector.WordEditor
needs to be followed by
wEditor.Range(0, 0).Select
to avoid an error sometimes when you go to paste it.
You can modify the code put the Body on the Clipboard and Paste it:
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(olMailItem)
mail.Display
mail.To = "A#a.com"
mail.Subject = "subject" & Now
Dim Clip As MSForms.DataObject
Set Clip = New MSForms.DataObject
Clip.SetText ("test ... body" & vbNewLine & vbNewLine _
& "this is another line " & vbCrLf _
& "this is another line again " & vbNewLine & " ")
Clip.PutInClipboard
Set wEditor = mailApp.ActiveInspector.wordEditor
wEditor.Application.Selection.Paste
ActiveChart.ChartArea.Copy ' chart needs to be active
wEditor.Application.Selection.Paste
' mail.send
In this case you can assembly the mail as you want.
MSForms.DataObject need to have the Reference: Microsoft Form 2.0 Object Library (FM20.DLL)
You can try also with another code (in this case the image are temporary saved on disk):
Sub CopyAndPasteToMailBody4() ' this works but how do i control where it puts the chart?
Set mailApp = CreateObject("Outlook.Application")
Set mail = mailApp.CreateItem(0)
mail.Display
mail.To = "A#a.com"
mail.Subject = "subject" & Now
Dim Stri As String
Stri = "test ... body" & vbNewLine & vbNewLine _
& "this is another line " & vbCrLf _
& "this is another line again " & vbNewLine & " "
ActiveChart.Export "e:\0\C1.png"
Stri = Stri & "<img src='e:\0\C1.png'>"
mail.HTMLBody = Stri
' mail.send
End Sub
On my PC the first code ask me some permission, with the second code no...