I am using the below code. It works find without the attachment line of code. But once I add the attachment line if get an error and can not work out how to correct it:
Dim Email
Dim CC
Dim objOutlook As Object
Dim objEmail As Object
Dim db As Database
Dim rec As Recordset
'Export report in same folder as db with date stamp
todayDate = Format(Date, "MMDDYYYY")
fileName = Application.CurrentProject.Path & "\XXDispute_" & todayDate & ".pdf"
DoCmd.OutputTo acReport, "XXDispute", acFormatPDF, fileName, False
strItem = "http://schemas.microsoft.com/cdo/configuration/"
strFrom = "XX Disputes <asd#asd.com>"
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = CreateObject("CDO.Message")
With objEmail
.To = "asd#asd.com"
.CC = ""
.From = strFrom
.Subject = "XXDispute Report: " & Now()
.Textbody = "Your XX dispute has been reviewed and responded to:" & vbNewLine & vbNewLine
.Attachments Add = fileName
With .Configuration.Fields
.Item(strItem & "sendusing") = 2
.Item(strItem & "smtpserver") = "mailhost"
.Item(strItem & "smtpserverport") = 25
.Update
End With
.Send
End With
This is the particular line causing the problem:
.Attachments Add = fileName
Related
I want to send a personalized email generated by Excel VBA.
The email contains personalized text followed by a html file that contains images.
I tried the following code but the images are not displayed.
Sub Mail_Outlook_With_Html_Doc()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim oFSO As Object
Dim oFS As Object
Dim sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile("C:\....\invite.htm")
Do Until oFS.AtEndOfStream
sText = oFS.ReadAll()
Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'strbody = personalized email body generated here
On Error Resume Next
With OutMail
.display
.To = ToAdd
.CC =
.BCC = ""
.Subject = "Test Email"
.ReadReceiptRequested = True
' the html file is appended here to the personalized email body generated
.HTMLBody = strbody & sText
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The invite.htm referred above contains images which are not visible when the email is sent. Neither in the email messages sent nor in the email messages received.
Here ia an example that works for me you need to adapt it according to your needs.
This will embed the image in the body of the email and will attach it from what I remember. Please note you need to display the email first and then send it that is the only way to show on different device, i learn that the hard way. It can be done via code as the below example if you want to display and review the email just comment out the .Send after you are happy you can press manually send.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
This question already has answers here:
How to keep formats when I copy a range from Excel to outlook
(2 answers)
Closed 3 years ago.
All,
I have been using the below code to generate an email which compiles a range into an HTML body of an email.
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lastrow As Long
Dim sht As Worksheet
Dim StrBody As String
Set rng = Nothing
Sheets("HTML Loop").Activate 'Change
Set sht = ActiveSheet
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Range
On Error Resume Next
Set rng = sht.Range("A1:A" & lastrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If sht.Range("A1").Value = "" Then
Exit Sub
End If
StrBody = "All," & "<br>" & "<br>" & _
"The Robot has completed its daily check of the FX3 Site and has created " & lastrow & " new folder location(s)." & "<br>" & "<br>" & _
"*Please review the files located here:"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Sean.B#xxx.co.uk"
.CC = ""
.BCC = ""
.Subject = "Daily FX3 Notification Email " & Now()
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & "<br>" & "<br>" & "Thanks" & "<br>" & "<br>" & "Gary"
.Display
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutA
End sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
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
rng.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
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
The issue I am having is when the email is generated, the strings within the range is cut at 9 Characters long.
The range consists of file paths like the below:
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Bristol\TEST TEST 108 EastCott Hill
\csdatg09\financial systems\Automation\Pega Projects\Tax\FIN_TAX_GARY\Exeter\TEST TEST 108 EastCott Hill
I would like to understand why the output is like the screenshot attached.
All, this is a duplicate question the answer I was looking for can be found here:
How to keep formats when I copy a range from Excel to outlook
Specific Code:
TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
'.Cells(1).PasteSpecial xlPasteValues, , False, False
'.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
I'm having trouble getting a range that is embedded in an email to left align. I've tried several things but the embedded portion still centers in the email. Here is my code, which ironically, works just fine in other spreadsheets. I've tried adding HTML tags, changing the function(s), all to no avail. Any help would be appreciated. This is on W7x64 and Office 2010. In this report I am embedding a pivot table instead of a regular range.
Thanks.
Option Explicit
SalesSub Mail_RegionalRANGE()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
'On Error Resume Next
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.SentOnBehalfOfName = "SalesAnalytics#company.us"
.Display
.Subject = "Sales Report"
.To = "mike.marshall#company.us"
'.CC =
'.BCC =
'.Attachments.Add "\\filesrv1\department shares\Sales Report\Sales Report.xlsx"
.HTMLBody = "<br>" _
& "Attached is the Sales Report. Please reach out to me with any questions." _
& "<br><br>" _
& "<p align=left>" & fncRangeToHtml("RegAEPctg", "B2:P67") & "<p>" _
& .HTMLBody
.Display
'.Send
End With
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
Private Function fncRangeToHtml( _
strWorksheetName As String, _
strRangeAddress As String) As String
Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
Dim strFilename As String, strTempText As String
Dim blnRangeContainsShapes As Boolean
Set objTextstream = Nothing
Set objFilesytem = Nothing
'Kill strFilename
strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True
Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
objTextstream.Close
strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=")
For Each objShape In Worksheets(strWorksheetName).Shapes
If Not Intersect(objShape.TopLeftCell, Worksheets( _
strWorksheetName).Range(strRangeAddress)) Is Nothing Then
blnRangeContainsShapes = True
Exit For
End If
Next
If blnRangeContainsShapes Then _
strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
fncRangeToHtml = strTempText
Set objTextstream = Nothing
Set objFilesytem = Nothing
Kill strFilename
End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
Const HTM_START = "<link rel=File-List href="
Const HTM_END = "/filelist.xml"
Dim strTemp As String
Dim lngPathLeft As Long
lngPathLeft = InStr(1, strTempText, HTM_START)
strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
strTemp = strTemp & "/"
strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp)
fncConvertPictureToMail = strTempText
End Function
I'm not a 100% sure but this seems to be cause by your rng to html function.
I had a similar problem with an older range to html I was using, so my solution is a kind of workaround, by rewriting the function you are using.
Can't comment for lack of rep, so please take it with a grain of salt.
I'd suggest using this range_to_html function and expanding it with a workbook open/activate call for your workbook/sheet:
Function RangetoHTML(rng As Range) ' converts a range into html for email-sendout'
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim FSO As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy the range and create a workbook to receive the data.
rng.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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set FSO = Nothing
Set TempWB = Nothing
End Function
I've used this for everything range related and no matter what it picked out it was always in line with the general email format.
Source: http://www.mrexcel.com/forum/excel-questions/485720-ron-de-bruin-rangetohtml.html
Since you are reading directly from the file the html might contain the allign command for the code. This one here does copying, and republishing which should circumvent the issue.
I'm also not sure how this code handles shapes, so it might not work for ranges with shapes.
Also if I misunderstood and the problem is that the text in the cells is left aligned lemme know, that would be easier to identify and fix.
I do not know how to get this thing to work beyond this point.
My code below sends an email containing an attachment out of MS Access 2010.
The problem is if it requires a fixed file name, my file name changes as I am using the date at the end of each file. example: green_12_04_2012.csv. I also do not know how to make this not fail if the folder is empty or the directory changes. It would be great for it to just skip to the next sub rather than crashing.
My Code:
Dim strGetFilePath As String
Dim strGetFileName As String
strGetFilePath = "C:\datafiles\myfolder\*.csv"
strGetFileName = Dir(strGetFilePath)
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "bob#builder.com"
''.cc = ""
''.bcc = ""
.Subject = "text here"
.HTMLBody = "text here"
.Attachments.Add (strGetFileName & "*.csv")
.Send
End With
End Sub
I think I am getting there.
I found a suitable resolution and in addition to the solution posted, I wanted to add this in-case anyone is searching for the solution. I was up until 3am, this is a very popular question but there was not any resolution in regards to looping an attaching all files in a specific folder.
Here is the code:
Public Sub sendEmail()
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim strPath As String
Dim strFilter As String
Dim strFile As String
strPath = "C:\Users\User\Desktop\" 'Edit to your path
strFilter = "*.csv"
strFile = Dir(strPath & strFilter)
If strFile <> "" Then
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "bob#builder.com"
''.cc = ""
''.bcc = ""
.Subject = "text here"
.HTMLBody = "text here"
.Attachments.Add (strPath & strFile)
.Send
'.Display 'Used during testing without sending (Comment out .Send if using this line)
End With
Else
MsgBox "No file matching " & strPath & strFilter & " found." & vbCrLf & _
"Processing terminated.
Exit Sub 'This line only required if more code past End If
End If
End Sub
heres code i found on one of the forums and cant remember where, but i modified it slightly
this gives you full path of the file, it searches folder and subfolders using wildcard
Function fSearchFileWild(FileName As String, Extenstion As String)
Dim strFileName As String
Dim strDirectory As String
strFileName = "*" & FileName & "*." & Extenstion
strDirectory = "C:\Documents and Settings\"
fSearchFileWild = ListFiles(strDirectory, strFileName, True)
End Function
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
Dim counter As Integer
counter = 0
Dim file1 As String
Dim file2 As String
Dim file3 As String
For Each varItem In colDirList
If file1 = "" Then
file1 = varItem
counter = 1
ElseIf file2 = "" Then
file2 = varItem
counter = 2
ElseIf file3 = "" Then
file3 = varItem
counter = 3
End If
Next
'if there is more than 1 file, msgbox displays first 3 files
If counter = 1 Then
ListFiles = file1
ElseIf counter > 1 Then
MsgBox "Search has found Multiple files for '" & strFileSpec & "', first 3 files are: " & vbNewLine _
& vbNewLine & "file1: " & file1 & vbNewLine _
& vbNewLine & "file2: " & file2 & vbNewLine _
& vbNewLine & "file3: " & file3
ListFiles = "null"
Else
ListFiles = "null"
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function
I need to send a series of email notifications from an MS Access Database.
No third party dll's like Redemption
Cannot trip the outlook security warnings
The email will have a pdf attachment
I know to do this I need to use MAPI, but I can't seem to find a way to do this with VBA.
Any help would be appreciated
Thanks,
Scott
If you can live with requiring CDO to be present on the machine, and you don't mind a user-provided SMTP server, you can use that. Just google for some example code, but for you convenience I'll paste some below from www.rondebruin.nl :
Sub CDO_Mail_Small_Text()
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/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
' = "Fill in your SMTP server here"
' .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 = "ron#debruin.nl"
.CC = ""
.BCC = ""
.From = """Ron"" <ron#something.nl>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
End Sub
Adding an attachment would be done using .AddAttachment "C:\files\filename.pdf" on the iMsg.
If the user has outlook installed:
Dim strErrMsg As String 'For Error Handling
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim oleGrf As Object
Dim strFileName As String
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olMail = olApp.CreateItem(olMailItem)
Set oleGrf = Me.OLEchart.Object
strFileName = "c:\temp\Graph.jpg"
oleGrf.Export FileName:=strFileName
With olMail
.To = "someone#somewhere.com"
.Subject = "Graph Info " & Format(Now(), "dd mmm yyyy hh:mm")
.Attachments.Add strFileName
.ReadReceiptRequested = False
.Send
End With
Kill strFileName
Also check out Tony Toews's Microsoft Access Email FAQ
See the page Microsoft Access Email FAQ - Directly via the Winsock I haven't tried those myself but you should be able to adapt the VB6 code to send the emails directly.