I am using the code below to create and send an email from excel using IBM Notes.
I have tried and tried to get this email to save into a folder as a PDF or just print it so i can print it as a PDF.
Whatever i try i cannot seem to get this to print/save as PDF. The rest of the code is working fine.
I came close, by using this piece of code (which saves the attachment from each email as it's being created).
Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")
EmbedObj .ExtractFile "C:\attach\" & EmbedObj .Name
I even tried changing this to:
Set doc = db.CreateDocument
doc.ExtractFile "C:\attach\" & "SomeFileName.pdf"
But alas this produces a object doesn't support this property or method error.
I am also trying this:
doc.Print True, False
But still no luck.
My full code:
Sub Send()
ActiveSheet.DisplayPageBreaks = False
Dim answer As Integer
answer = MsgBox("Are you sure you want to Send All Announcements?", vbYesNo + vbQuestion, "Notice")
If answer = vbNo Then
Exit Sub
Else
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Attachment As String
Dim WB3 As Workbook
Dim WB4 As Workbook
Dim Rng As Range
Dim db As Object
Dim doc As Object
Dim body As Object
Dim header As Object
Dim stream As Object
Dim session As Object
Dim i As Long
Dim j As Long
Dim j2 As Long
Dim server, mailfile, user, usersig As String
Dim LastRow As Long, LastRow2 As Long, WS As Worksheet
LastRow = Worksheets(1).Range("F" & Rows.Count).End(xlUp).Row 'Finds the last used row
j = 18
With ThisWorkbook.Worksheets(1)
For i = 18 To LastRow
'Start a session of Lotus Notes
Set session = CreateObject("Notes.NotesSession")
'This line prompts for password of current ID noted in Notes.INI
Set db = session.CurrentDatabase
Set stream = session.CreateStream
' Turn off auto conversion to rtf
session.ConvertMime = False
'Email Code
'Create email to be sent
Set doc = db.CreateDocument
doc.Form = "Memo"
Set body = doc.CreateMIMEEntity
Set header = body.CreateHeader("Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
Call header.SetHeaderVal("HTML message")
'Set From
Call doc.ReplaceItemValue("Principal", "Food Specials <mailto:Food.Specials#Lidl.co.uk>")
Call doc.ReplaceItemValue("ReplyTo", "Food.Specials#Lidl.co.uk")
Call doc.ReplaceItemValue("DisplaySent", "Food.Specials#Lidl.co.uk")
Call doc.ReplaceItemValue("Subject", "Promotion Announcement for week " & Range("I8").value & ", " & Range("T8").value & " - Confirmation required")
'To
Set header = body.CreateHeader("To")
Call header.SetHeaderVal(Range("N" & i).value)
'Email Body
Call stream.WriteText("<HTML>")
Call stream.WriteText("<font size=""3"" color=""black"" face=""Arial"">")
Call stream.WriteText("<p>Good " & Range("A1").value & ",</p>")
Call stream.WriteText("<p>Please see attached an announcement of the spot buy promotion for week " & Range("I8").value & ", " & Range("T8").value & ".<br>Please check, sign and send this back to us within 24 hours in confirmation of this order. Please also inform us of when we can expect the samples.</p>")
Call stream.WriteText("<p>The details are as follows:</p>")
'Insert Range
Set WB3 = Workbooks.Open(Range("F" & i).value)
With WB3.Sheets(1)
.Range("A20:J39").SpecialCells(xlCellTypeVisible).Select
Set Rng = Selection
End With
Call stream.WriteText(RangetoHTML(Rng))
WB3.Close SaveChanges:=False
'Attach file
Attachment = Range("F" & i).value
Set AttachME = doc.CREATERICHTEXTITEM("attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", Attachment, "")
Call stream.WriteText("<BR><p>Please note the shelf life on delivery should be 75% of the shelf life on production.</p></br>")
'Signature
Call stream.WriteText("<BR><p>Kind regards / Mit freundlichen Grüßen,</p></br>")
Call stream.WriteText("<p><b>Lidl UK Food Specials Team</b></p>")
Call stream.WriteText("<table border=""0"">")
Call stream.WriteText("<tr>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/layout/top_logo2016.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("<td><img src=""http://www.lidl.co.uk/statics/lidl-uk/ds_img/assets_x_x/BOQLOP_NEW%281%29.jpg"" alt=""Mountain View""></td>")
Call stream.WriteText("</tr>")
Call stream.WriteText("</table>")
Call stream.WriteText("</font>")
Call stream.WriteText("</body>")
Call stream.WriteText("</html>")
Call body.SetContentFromText(stream, "text/HTML;charset=UTF-8", ENC_IDENTITY_7BIT)
doc.Print True, False
doc.Save True, False
Call doc.PutInFolder("TEST")
Call doc.Send(False)
session.ConvertMime = True ' Restore conversion - very important
'Clean Up the Object variables - Recover memory
Set db = Nothing
Set session = Nothing
Set stream = Nothing
Set doc = Nothing
Set body = Nothing
Set header = Nothing
'WB3.Close savechanges:=False
Application.CutCopyMode = False
'Email Code
j = j + 1
Next i
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Success!" & vbNewLine & "Announcements have been sent."
MsgBox doc.GetItemValue("subject")(0)
End If
End Sub
Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-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 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
Please can someone show me where I am going wrong?
The Notes APIs don't have the ability to save a message as a PDF.
You can't pass a range to EmbedObject. EmbedObject wants a filename - for a file that you've already saved to disk. You can create a PDF and attach it to an email using EmbedObject. If someone has already created a PDF and attached it to an email, you can save the PDF to disk using ExtractFile - which, as you found through your second attempt is a method of the NotesRichTextItem class, not the NotesDocument class. And as for your final attempt, the NotesDocument class does not have a print method, either.
To the best of my knowledge, the only solutions for saving Notes email messages as PDF files require third-party commercial software. (There are some PDF-related open source projects on the OpenNTF website, but I believe they are all based on Lotus XPages technology, which you cannot access from VBA.)
Related
I have a semi-working macro that
Loops through a list of Managers
Generates a email body for each manager
Filters a sheet of all data relevant for each manager
Converts the visible cells to a HTML table
Adds the table to email
Send
The issue is the macro stops generating emails every 50 iterations in and does not error out - it just appears to "run" without doing anything. I have manually stopped the macro and there is no consistent line that appears to be getting stuck. Cutting this down to bare bones as much as I can, but I have no clue where the issue is. When I step through, I can't recreate the issue. When I re-run, the first 50ish go fine and then it stops generating.
I have also tried adding Application.Wait call at the end of each loop iteration and get same issue
I end up having to CTRL + BREAK to stop the macro. When I restart its coded to pick up right where it left off and it sends the next batch just fine (meaning the line it gets paused on runs just fine when I start again). Issue is not every once in a while - it's gets stuck like clock work.
Start of macro (just generates a text body)
Sub Initiate()
Dim EmailBody As String
EmailBody = "HTML TEXT BODY HERE"
Builder EmailBody '<---- Call loop
End Sub
Performs the loop on managers and filters the other sheet for relevant data. Passes all ranges on to the macro to build email
Sub Builder(EmailBody As String)
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Distro List")
Dim Raw As Worksheet: Set Raw = ThisWorkbook.Sheets("Email Data")
Dim LR As Long, LR2 As Long
Dim EmailTable As Range, Target As Range, EmailRange As Range
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set EmailRange = ws.Range("C2:C" & LR)
LR2 = Raw.Range("A" & Raw.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For Each Target In EmailRange
If Target.Offset(, -2) = "y" Then
If Len(Target.Offset(, -1)) = 6 Then
If Right(Target.Offset(, 1), 7) = "#so.com" Or Right(Target.Offset(, 1), 11) = "#StackO.com" Then
Raw.Range("A1:H" & LR2).AutoFilter 1, Target.Offset(, -1), VisibleDropDown:=False
Raw.Range("A1:H" & LR2).SpecialCells(xlCellTypeVisible).Columns.AutoFit
Set EmailTable = Raw.Range("A1:H" & LR2).SpecialCells(xlCellTypeVisible)
Sender EmailBody, EmailTable, Target
Set EmailTable = Nothing
End If
End If
End If
Next Target
Application.ScreenUpdating = True
End Sub
Build email, call HTML Table generator macro, add HTML Table, SEND email
Sub Sender(EmailBody As String, EmailTable As Range, Target As Range)
Dim OutApp As Object
Dim OutMail As Object
On Error GoTo BNP:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "urdearboy#so.com"
.to = Target.Offset(, 1)
.Subject = "Your Employees....."
.HTMLBody = "<p style = 'font-family:arial' >" _
& EmailBody & "</p>" _
& RangetoHTML(EmailTable) _
& "<p style = 'font-family:arial' >"
.Send
Target.Offset(, -2) = "Sent"
End With
BNP:
Set OutApp = Nothing
Set OutMail = Nothing
End Sub
Macro I found online that converts a excel range to a HTML table that can be inserted into email.
Function RangetoHTML(EmailTable 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"
EmailTable.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
Extremely glad, yet also annoyed, to say that adding a Applitcation.Wait for 1 second to the function RangetoHTML fixed the issue.
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Application.Wait Now + #12:00:01 AM# '<------ Resolved Issue
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Still curious to know what the actual issue is since I suspect that this is a work around to the actual issue. Just glad I can finally use this macro to send large distro's without it pausing every 4 minutes!
I have correctly created the HTMLBody and Signature scrub code from previous code discussions. I have the macro creating the direct binding to the image file and using .send, but when I do this nothing is displayed on the receivers end.
Although, when I use .display and then using send off of the display the image correctly is attached. The file I am using is not in the /Signatures path so Outlook would not have access to the file to 'attache' correctly.
The original code had the signature in reference.. that of course didnt work.
The second instance I used the GetSignature function that is generally the fix.
I then added a direct reference to the image as an additional line in the email construct just to make sure I wasnt doing something boneheaded.
I have also pulled the return HTML fro GetSignature and the altered HTML from the VBA.Replace .. everything points back to a valid file on the workstation.
Dim OutApp, OutMail As Object
Dim ws, wsTemp, wsEmail As Worksheet
Dim tempLO As Range
Dim TagName, NameValue, LangValue, DocLoc, compFilename, NameLine As String
Dim emSalutation, emBody, emClose As String
Dim StrSignature, LangCert, LangSubject, LangSig, LangSheet, tempLoc, compLoc As String
Dim sPath As String
Dim signImageFolderName, signImageOutlookFolder As String
Dim completeFolderPath, completeTempPath, completeCompPath As String
Dim lastRow As Long
Dim mailSTR As String
Dim runDate, SkipValue, errorTxt As String
Dim answer, emailCnt, certCnt As Integer
Dim testin As Boolean
Dim sTxtFilePath As String
Dim txtFileNumber As Integer
Set ws = Sheets("Certificates")
Set wsTemp = Sheets("Templates")
Set tempLO = wsTemp.Range("Template_Table")
Set OutApp = CreateObject("Outlook.Application")
DocLoc = wsTemp.Range("B2").Value
'Get the row data from Certificates to work with, name and lang
NameValue = .Cells(i, 1).Value
LangValue = .Cells(i, 3).Value
SkipValue = .Cells(i, 4).Value
'Get the Certificate, Email Subject, Email Tab and Email Signature for the correct set language
LangCert = Application.WorksheetFunction.VLookup(LangValue, tempLO, 2, False)
LangSubject = Application.WorksheetFunction.VLookup(LangValue, tempLO, 3, False)
LangSig = Application.WorksheetFunction.VLookup(LangValue, tempLO, 4, False)
LangSheet = "Email_" & LangValue
Set wsEmail = Sheets("Email_" & LangValue)
sPath = DocLoc & LangSig & ".htm"
signImageFolderName = LangSig & "_files"
signImageOutlookFolder = signImageFolderName & "/"
completeFolderPath = DocLoc & signImageFolderName & "\"
errorTxt = OpenFile(DocLoc & LangSig & ".htm")
errorTxt = Folder_Exist_With_Dir(DocLoc & signImageFolderName, 3)
StrSignature = GetSignature(sPath)
StrSignature = VBA.Replace(StrSignature, signImageOutlookFolder, completeFolderPath)
Print #txtFileNumber, StrSignature
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Not IsEmpty(wsTemp.Range("B7").Value) And (wsTemp.Range("B7").Value Like "?*#?*.?*") Then
.SentOnBehalfOfName = wsTemp.Range("B7").Value
End If
.Subject = LangSubject
emSalutation = "<font style=""font-family: Calibri; Color: #1F497D; font-size: 14pt;""/font>" & _
ws.Range("A" & i).Value & ";<br>"
emBody = RangetoHTML(wsEmail.UsedRange)
emClose = "<br>" & StrSignature _
& "<br>" _
& "<img src='C:\<directory path to OneDrive Folder>\BTSL_SecAware_files\image001.png'>"
.HTMLBody = emSalutation & emBody & emClose
If IsEmpty(ws.Range("B" & i).Value) Or Not (ws.Range("B" & i).Value Like "?*#?*.?*") Then
.To = "Display Only"
.Display 'or use
Else
.To = ws.Range("B" & i).Value
.Send
emailCnt = emailCnt + 1
End If
End With
Set OutMail = Nothing
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Function GetSignature(ByVal fPath As String) As String
Dim fso As Object
Dim TSet As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
GetSignature = TSet.ReadAll
TSet.Close
End Function
The code basically boils down to pull the signature file from a directory read in the text file of the .htm and update it with something different.. In this instance a qualified directory path.
When this is run and this file is added to the Htmlbody and .sent it does not embed the image, but when it is .displayed and then sent it embeds.
<link rel=File-List href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\filelist.xml">
<link rel=Edit-Time-Data href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\editdata.mso">
<!--[if !mso]>
<style>
v\:* {behavior:url(#default#VML);}
o\:* {behavior:url(#default#VML);}
w\:* {behavior:url(#default#VML);}
.shape {behavior:url(#default#VML);}
</style>
<![endif]--><!--[if gte mso 9]><xml>
<o:OfficeDocumentSettings>
<o:AllowPNG/>
</o:OfficeDocumentSettings>
</xml><![endif]-->
<link rel=themeData href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\themedata.thmx">
<link rel=colorSchemeMapping href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\colorschememapping.xml">
<!--[if gte mso 9]><xml>
Basically I created a report and then send it via an email. I use Ron B's function to paste the excel sheets into the body of the email. What happens is excel doesn't destroy or close after the send email function is done. When I end task on it and run it again it says that the remote machine or server doesn't exits. This is probably because I am not explicitly defining the objects but I don't know how to between the two procedures. I tried making the xlApp Public but that didn't work. I even tried adding it to the rangetohtml function but at the point of where it says rng.copy it says there is an object that is required. I tried adding xlApp.rng.copy or wb.rng.copy or ws.rng.copy. So i have the below where the range to html copies the rng. That is added to a temp workbook and copied into the email. It call from the one function over to the other and I can't figure out how to destroy the excel session when it is done.
Set rng = xlApp.Selection.SpecialCells(xlCellTypeVisible)
Set rng = wb.Sheets(2).Range("A:U").SpecialCells(xlCellTypeVisible)
Set rng2 = xlApp.Selection.SpecialCells(xlCellTypeVisible)
Set rng2 = wb.Sheets(1).Range("A:U").SpecialCells(xlCellTypeVisible)
Now the range to html says RangetoHtml(rng as Range) then at the bottom it says
rng.copy
Below that when you debug it after end tasking on excel it stops on this line:
Set TempWB = Workbooks.Add(1)
I know you are supposed to put either XlApp.Workbooks.Add(1) but in the rangeto Html function it isn't declared as an object but it is in the function that it is calling from. I don't know what to do next and how to fix the code. I am posting both functions so you can see the code. When the send email happens it brings up the email and pastes the excel sheet into the email but excel doesn't closed.
Public Function sendEmailorbetechprealert()
Dim appOutLook As Outlook.Application
Dim Items As Outlook.Items
Dim Item As Object
Dim strPath As String
Dim strFilter As String
Dim strFile As String
Dim rng As Range
Dim rng2 As Range
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim MyFileName As String
Dim bfile As String
Dim Cell As Range
bfile = "S:\_Reports\Orbotech\Orbotech - Open Deliveries Pre-Alert\Orbotech - Open Deliveries Pre-Alert - "
MyFileName = bfile & Format(Date, "mm-dd-yyyy") & ".xls"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err.Number > 0 Then Set xlApp = CreateObject("Excel.Application")
On Error GoTo 0
Set wb = xlApp.Workbooks.Open(MyFileName)
Set ws = wb.Sheets(1)
ws.Activate
Set rng = Nothing
Set rng2 = Nothing
On Error Resume Next
Set rng = xlApp.Selection.SpecialCells(xlCellTypeVisible)
Set rng = wb.Sheets(2).Range("A:U").SpecialCells(xlCellTypeVisible)
Set rng2 = xlApp.Selection.SpecialCells(xlCellTypeVisible)
Set rng2 = wb.Sheets(1).Range("A:U").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
Set appOutLook = Nothing
Set Items = Nothing
End If
If rng2 Is Nothing Then
Set appOutLook = Nothing
Set Items = Nothing
Exit Function
End If
strPath = "S:\_Reports\Orbotech\Orbotech - Open Deliveries Pre-Alert\" 'Edit to your path
strFilter = "*.xls"
strFile = Dir(strPath & strFilter)
'For Each Cell In Columns("E").Cells.SpecialCells(xlCellTypeConstants)
If strFile <> "" Then
Set appOutLook = CreateObject("Outlook.Application")
Set Items = Outlook.Application.ActiveExplorer.CurrentFolder.Items
Set Item = Items.Add("IPM.Note.iCracked")
With Item
.To = ""
'.CC =
''.bcc = ""
.Subject = "Orbotech Open Deliveries Report Pre-Alert"
.htmlBody = "This is the Open Deliveries Report. Please open the attachment. These lines are what have been inbound." & RangetoHTML(rng) & "This is what is still due" & RangetoHTML(rng2)
.Attachments.Add (strPath & strFile)
'.Send
Item.Display 'Used during testing without sending (Comment out
.Send if using this line)
wb.CheckCompatibility = False
wb.Save
wb.CheckCompatibility = True
DoEvents
End With
Else
MsgBox "No file matching please re run Orbotech Report"
Exit Function 'This line only required if more code past End If
End If
'Next Cell
DoEvents
On Error GoTo 0
wb.CheckCompatibility = False
wb.Save
wb.CheckCompatibility = True
xlApp.Quit
Set rng = Nothing
Set rng2 = Nothing
Set wb = Nothing
Set ws = Nothing
Set xlApp = Nothing
Exit Function
End Function
Now in the htmlbody it calls the RangetoHtml(rng) to paste it in the email. He is the rangetohtml function:
Public Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
'xlApp.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.CheckCompatibility = False
TempWB.Save
TempWB.CheckCompatibility = True
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
Any help that anyone can provide it would certainly be appreciated.
I'm trying to modify Ron de Bruin's code to send a chart in mail body.
I export the chart and save it as an PNG image, then I modify HTML code to add it to the message.
The code should run on a server and send mails to people in my workplace.
When using MailItem.Display and manually clicking "send" when my message appears, everything works.
When I try to use MailItem.Send I get an icon in the mail body like it tried to attach an image which it couldn't find.
When I send that mail from a server, on a server account, the chart is displayed correctly.
It doesn't work when I try to send it on "local" computers.
Sub wyslij()
NameOfThisFile = ActiveWorkbook.Name
Dim rng As Range
Dim dataminus1, dataminus2 As Date
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
Set rng = Nothing
Set rng = Sheets(2).Range("E1:P13")
olMail.To = "xxx#xxx"
olMail.CC = "xxxx#xxx"
olMail.Subject = "xxxx"
olMail.HTMLBody = RangetoHTML(rng)
olMail.Display
'olMail.Send
'Delete file after sending a mail
'Call DeleteFile(Path)
End Sub
Sub Save_ChartAsImage()
ChartEx = False
Dim cht As ChartObject
For Each cht In ActiveSheet.ChartObjects
If cht.TopLeftCell.Column = ChartCol And cht.TopLeftCell.Row = ChartRow Then
ChartEx = True
On erRROR GoTo Err_Chart
cht.Chart.Export Filename:=ActiveWorkbook.Path & "\Chart.png", Filtername:="PNG"
End If
Next cht
Err_Chart:
If Err <> 0 Then
Debug.Print Err.Description
Err.Clear
End If
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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 xlPasteAll
.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
'kopiujemy wykres z poprzedniego działu
'Workbooks("WplatyFinal.xlsm").Activate
Workbooks(NameOfThisFile).Activate
Call Save_ChartAsImage
TempWB.Activate
TempWB.Sheets(1).Select
'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
If ChartEx Then
RangetoHTML = RangetoHTML & "<img src ='" & ActiveWorkbook.Path & "\Chart.png" & "'>"
End If
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
I tried to use the Wait function directly after the Send method.
Getting the images to appear as inline is certainly possible. The img src in the HTML must refer to the cid with an identifier for the image. The code below sets up the email and adds all of the chart objects as inline images to an email.
Option Explicit
Sub CreateEmail()
Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Dim wb As Workbook
Dim ws As Worksheet
Dim olApp As Object
Dim olMail As Object
Dim msg As String
Dim msgGreeting As String
Dim msgPara1 As String
Dim msgEnding As String
Dim chrt As ChartObject
Dim fname As String
Dim ident As String
Dim tempFiles As Collection
Dim imgIdents As Collection
Dim imgFile As Variant
Dim attchmt As Object
Dim oPa As Object
Dim i As Integer
'--- create the email body with HTML-formatted content
msgGreeting = "<bold>Dear Sirs</bold>,<br><br>"
msgPara1 = "<div>Here is the data you requested:</div>"
msgEnding = "<br><br>Sincerely,<br>JimBob<br>"
'--- build the other email body content
Set wb = ActiveWorkbook
Set ws = ActiveSheet
msg = msgGreeting & msgPara1
'--- loops and adds all charts found on the worksheet
If ws.ChartObjects.Count > 0 Then
Set tempFiles = New Collection
Set imgIdents = New Collection
For Each chrt In ws.ChartObjects
fname = ""
msg = msg & ChartToEmbeddedHTML(chrt, fname, ident) & "<br><br>"
tempFiles.Add fname
imgIdents.Add ident
Next chrt
End If
msg = msg & msgEnding
'--- create the mail item
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0) 'olMailItem=0
With olMail
.To = "yyy#zzzz.com"
'.CC = "xxxx#xxx"
.Subject = "xxxx"
.bodyformat = 2 'olFormatHTML=2
'--- each of the images is referenced as a filename, but each one must be
' individually added as an attachment, then the attachment properties
' set to show the attachment as "inline". Because the image will be
' inlined, we'll use the "ident" as the reference (internal to the
' message body HTML)
If (Not tempFiles Is Nothing) Then
For i = 1 To tempFiles.Count
Set attchmt = .attachments.Add(tempFiles.Item(i))
Set oPa = attchmt.PropertyAccessor
oPa.SetProperty PR_ATTACH_MIME_TAG, "image/png"
oPa.SetProperty PR_ATTACH_CONTENT_ID, imgIdents.Item(i)
Next i
End If
'--- the email item needs to be saved first
.Save
'--- now add the message contents
.htmlbody = msg
.display
End With
'--- delete the temp files now
For Each imgFile In tempFiles
Kill imgFile
Next imgFile
'--- clean up and get out
Set tempFiles = Nothing
Set imgIdents = Nothing
Set attchmt = Nothing
Set oPa = Nothing
Set olMail = Nothing
Set olApp = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Private Function ChartToEmbeddedHTML(thisChart As ChartObject, _
ByRef tmpFile As String, _
ByRef ident As String) As String
Dim html As String
ident = RandomString(8)
tmpFile = thisChart.Parent.Parent.Path & "\" & ident & ".png"
thisChart.Activate
thisChart.Chart.Export Filename:=tmpFile, Filtername:="png"
html = "<img alt='Excel Chart' src='cid:" & ident & "'></img>"
ChartToEmbeddedHTML = html
End Function
Private Function RandomString(strlen As Integer) As String
Dim i As Integer, iTemp As Integer, bOK As Boolean, strTemp As String
'48-57 = 0 To 9, 65-90 = A To Z, 97-122 = a To z
'amend For other characters If required
For i = 1 To strlen
Do
iTemp = Int((122 - 48 + 1) * Rnd + 48)
Select Case iTemp
Case 48 To 57, 65 To 90, 97 To 122: bOK = True
Case Else: bOK = False
End Select
Loop Until bOK = True
bOK = False
strTemp = strTemp & Chr(iTemp)
Next i
RandomString = strTemp
End Function
Excellent! I couldn't manage to attach the active workbook into the mail.
I tried to add the code .Attachments.Add (ActiveWorkbook.FullName) but didn't work, I received a message saying that the file is in use, and sometimes Runtime error 424 - Object required
With olMail
.To = "yyy#zzzz.com"
'.CC = "xxxx#xxx"
.Subject = "xxxx"
.Attachments.Add (ActiveWorkbook.FullName) ' this i added
I have a vba script that copies the selected range of cells and pastes it in the body of an email. Within that selected range of cells is an image of my company logo. Everything copies and pastes fine except the image.
Is there something I need to do to the image itself, to maybe "embed" it into the worksheet so it copies along with the cells?
Or is there something I need to do in the vba script to copy the image along with the cells?
Here is the full code:
Sub copyObjects()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String, signature As String
Dim OutlApp As Object
Dim RngCopied As Range
Set RngCopied = Selection
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
.Display ' We need to display email first for signature to be added
.Subject = Title
.To = ActiveSheet.Range("E10").Value ' <-- Put email of the recipient here or use a cell value
.CC = "whoever#abc.com; copy#abc.com" ' <-- Put email of 'copy to' recipients here
.HTMLBody = "Thank you for the opportunity to bid on the painting for " & ActiveSheet.Range("B9").Value & ". " & " Please read our attached proposal in it's entirety to be sure of all inclusions, exclusions, and products proposed. Give us a call with any questions or concerns." & _
vbNewLine & vbNewLine & _
RangetoHTML(RngCopied) & _
"Thank you," & _
.HTMLBody ' Adds default outlook account signature
On Error Resume Next
' Return focus to Excel's window
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
' MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
' Note: sometimes Outlook object can't be released from the memory
Set OutlApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-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 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
Set
Application.CopyObjectsWithCells = True
Before copying
If it helps, I have it in a macro like this...
The macro copies the aforementioned tabs which each contain Charts and Data Cells and Macro Buttons, into a new workbook.
The CopyObjects line, ensures that ALL the data on each tab is included in the copy. Without it, you may find that the charts and other drawn objects are excluded.
Caveat, I'm just about to post a question about an issue I have regarding this command. For some strange reason, just one single chart label is not being copied across - very strange so, be warned - check it works correctly for you.
Nick