I have the following code that sends a screenshot picture of a range> I would like to add text to the email but have not been able to figure out how.
Any help would be greatly appreciated.
'''
Public Sub ScreenShotResults2()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B20:I34")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B22").Value
.Subject = "4 Month LO Production Lookback for " & Worksheets("Summary").Range("B22").Value
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
'if need setup inlineshapes hight & width
With wdDoc
.InlineShapes(1).Height = 250
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
There are several ways to add the text. Here is one:
'if need setup inlineshapes hight & width
With wdDoc
.InlineShapes(1).Height = 250
.Paragraphs.Add
.Paragraphs.Add
.Content.InsertAfter "Please look at the range image!"
End With
EDIT: here is an expanded example to add text before and after the image (without using RangeToHTML)
Option Explicit
Public Sub ScreenShotResults2()
Dim rng As Range
Set rng = Sheets("Summary").Range("B20:I34")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim olApp As Outlook.Application
Dim Email As Outlook.MailItem
Dim wdDoc As Word.Document
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = Worksheets("Summary").Range("B22").Value
.Subject = "4 Month LO Production Lookback for " & _
Worksheets("Summary").Range("B22").Value
.Display
End With
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
.PasteAndFormat Type:=wdChartPicture
'--- now add our greeting at the start of the email
.InsertBefore "Dear Goober," & vbCr & vbCr & _
"See production data for most recent 3 months. " & _
vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & vbCr & _
"This is my final comment." & vbCr & vbCr & _
"Sincerely," & vbCr & _
"Me!"
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
Related
I create a picture of a range and paste it into Outlook. The code works but I added a checkbox that is located in the range that I do NOT want to paste into Outlook.
I used ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False. It works sometimes and other times it doesn't. When I step through the code I get the same inconsistent results.
Public Sub ScreenShotResults4_with_Current()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B9:N37")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'Sheets("Summary").Branch_ChkBox.Visible = False
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B21").Value
.Subject = "12 Month LO Production Lookback for " & Worksheets("Summary").Range("B21").Value & " (" & Worksheets("Summary").Range("B23").Value & "- " & Worksheets("Summary").Range("B35").Value & ")"
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
'if need setup inlineshapes hight & width
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
.PasteAndFormat Type:=wdChartPicture
.InlineShapes(1).Height = 350
'--- now add our greeting at the start of the email
.InsertBefore "See 12 month production data and current pipeline. " & vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & _
"Thank you" & vbCr & vbCr
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = True
End Sub
I was able to resolve by putting the same part of the code buy at the top right under the declarations
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
I'm trying to send mail using Mail MailEnvelope but the content is wrapped after sending the mail like below image.
Sub Sample_MailEnvelope()
Application.ScreenUpdating = False
Sheets("Mail").Visible = True
Dim foliorange As Range
Set foliorange = Sheets("Countsheet").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each mycell In foliorange
Worksheets("Mail").Unprotect (".")
Sheets("Mail").Range("A7:B7") = mycell.Offset(0, 2).Value
Sheets("Mail").Range("C7:D7") = mycell.Offset(0, 3).Value
Sheets("Mail").Range("E7:F7") = mycell.Offset(0, 4).Value
Dim Sendrng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Sheets("Mail").Activate
Range("A1").Select
Set Sendrng = Selection
With Sendrng
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
''.Introduction = "Hi," & vbNewLine & vbNewLine & "Kindly note that we have received the following transactions from you today." & vbNewLine & vbNewLine & vbNewLine & vbNewLine & vbNewLine
.Introduction = ""
With .Item
.To = mycell.Offset(0, 6).Value '"email#email.com"
.CC = mycell.Offset(0, 7).Value
.BCC = ""
.Subject = "OCBC - IUTA CONFIRMATION"
.Display
.send
End With
End With
End With
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = fasle
Next mycell
Worksheets("Mail").Protect "."
Sheets("Mail").Visible = False
Application.ScreenUpdating = True
End Sub
How to overcome this wrapping problem?
I tried to attach my sample macro file but I didn't find any option to attach files here.
Try something like below, modify as needed
Option Explicit
Public Sub Exampple()
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set Sht = ActiveWorkbook.Sheets("Mail")
Dim rng As Range
Set rng = Sht.Range("A7:E7")
rng.Copy 'Picture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = "email#email.com"
.Subject = "OCBC - IUTA CONFIRMATION"
.Attachments.Add ""
.Display
wdDoc.Paragraphs(1).Range.PasteAndFormat Type:=wdChartPicture
wdDoc.Paragraphs(1).SpaceAfter = 30
' if need setup inlineshapes hight & width
With wdDoc.InlineShapes(1)
.ScaleHeight = 113
.ScaleWidth = 114
End With
' .Display
.Send 'or use .Display
End With
Set wdDoc = Nothing
Set Email = Nothing
Set olApp = Nothing
End Sub
Make sure to Reference to Microsoft Word xx.x Object Library
https://stackoverflow.com/a/42662697/4539709
I generate reports to send to different branches. I run a macro that creates protected reports (*.xlsm). These reports have a space for comments for the Branch Managers, with a "send Comments" button that run this macro below.
I suggested the following references to add if the macro does not work.
The Branch Managers have different versions of MS Office (Excel, Outlook, etc.) on their laptops. When they try to Run, it shows errors, such as: "Error in Loadind DLL"; Error2, etc.
What should be done on the Branch Managers side to run this Macro?
Sub CommentsEmail()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Shell ("Outlook")
Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
template.Activate
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor
Set objSel = wordDoc.Windows(1).Selection
'construct the body of the email here
With objSel
'first text
.InsertAfter "Dear All," & vbCrLf
.Move wdParagraph, 1
'second text
.InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
.Move wdParagraph, 1
'copy a range and paste a picture
commentsrange.Copy ''again, you need to modify your target range
.PasteAndFormat wdChartPicture
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Kind Regards," & vbCrLf
End With
OutMail.To = OutMail.To & ";" & Sendto
With OutMail
.Subject = "Comments on Flash Indicator Results - " & branch
.Attachments.Add (ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Is this still early binding? If yes, I am totally lost.
Sub CommentsEmail2()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object
Dim TempFilePath As String
Dim xHTMLBody As String
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
template.Activate
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OleMail = olApp.CreateItem(0)
Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With OleMail
.Subject = "test"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Attachments.Add (ActiveWorkbook.FullName)
.To = " "
.Cc = " "
.Display
End With
Set OleMail = Nothing
Set OlaApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(comments).Activate
Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
I have a table in Excel that I want to send to a distribution list in Outlook with the table in the email body.
Using MVP Ron de Bruin's examples and a few others on here I've got code that keeps some of the table formatting but doesn't copy the cells colour if it is a gradient (please use the images as reference).
Sub DisplayEmailButton_Click()
Mail_Selection_Range_Outlook_Body
End Sub
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Sheet1").Range("C2:Q18").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
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 = "Team01"
.CC = ""
.BCC = ""
.Subject = "Daily Statistics"
.HTMLBody = "Please see attached daily statistics." & vbCrLf &
RangetoHTML(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim TempFile As String, ddo As Long
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Temporary publish the rng range to a htm file
ddo = ActiveWorkbook.DisplayDrawingObjects
ActiveWorkbook.DisplayDrawingObjects = xlHide
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
Source:=Union(rng, rng).Address, _
HtmlType:=xlHtmlStatic)
.Publish True
.Delete
End With
ActiveWorkbook.DisplayDrawingObjects = ddo
'Read all data from the htm file into RangetoHTML
With
CreateObject("Scripting.FileSystemObject").GetFile(TempFile)
.OpenAsTextStream(1, -2)
RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left
x:publishsource=")
.Close
End With
'Delete the htm file we used in this function
Kill TempFile
End Function
As Tim suggested I was expecting way too much from that procedure (Thank you, Tim, for the advice!) so I looked into a workaround. If the range is saved as a picture then it keeps all the formatting and the picture can then easily be attached to an email or displayed in the body of the email.
To save as a picture:
Dim Wb As ThisWorkbook
Dim Ws As Worksheet
Dim Ch As Chart
Set Rng = Ws.Range("A1:G18")
Set Ch = Charts.Add
Ch.Location xlLocationAsObject, "Sheet2"
Set Ch = ActiveChart
ActiveChart.Parent.Name = "StatsTemp"
ActiveSheet.ChartObjects("StatsTemp").Height = Rng.Height
ActiveSheet.ChartObjects("StatsTemp").Width = Rng.Width
Rng.CopyPicture xlScreen, xlBitmap
Ch.Paste
Ch.Export Environ("UserProfile") & "\Desktop" & "\" & Format("TempImage") & ".jpg"
Worksheets("Sheet2").ChartObjects("StatsTemp").Delete
Worksheets("Sheet1").Activate
The above code saves the range as an image "TempImage.JPG" to the users desktop by creating a new chart on sheet 2, pasting the range to the chart then saves the chart as an image and deletes the chart.
To attach the picture to an email in the email body:
Dim StrBody As String
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
StrBody = "Some text here." & "<br>"
On Error Resume Next
With OutMail
.to = "email address"
.CC = ""
.BCC = ""
.Subject = "Email Subject"
.HTMLBody = StrBody & "<img src = '" & Environ("userProfile") &
"\desktop\TempImage.jpg'>"
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
The above code creates an email using Microsoft Outlook which contains the saved image file in the email body and displays the email.
The image can be deleted after using:
Kill Environ("UserProfile") & "\Desktop" & "\TempImage.jpg"
Hopefully, this will be of some use to someone!
Credit to Ron de Bruin Microsoft Office MVP for his WinTips!
The code below is working fine the first time I run it, but when I need to run it a second time, it gives me this error:
Run Time error '462': the remote server machine does not exist or is unavailable
It doesn't happen all the time so I suppose it has something to do with Word (not) running in the background...? What am I missing here?
Sub Docs()
Sheets("examplesheet").Select
Dim WordApp1 As Object
Dim WordDoc1 As Object
Set WordApp1 = CreateObject("Word.Application")
WordApp1.Visible = True
WordApp1.Activate
Set WordDoc1 = WordApp1.Documents.Add
Range("A1:C33").Copy
WordApp1.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False
Application.Wait (Now + TimeValue("0:00:02"))
WordDoc1.PageSetup.TopMargin = CentimetersToPoints(1.4)
WordDoc1.PageSetup.LeftMargin = CentimetersToPoints(1.5)
WordDoc1.PageSetup.BottomMargin = CentimetersToPoints(1.5)
' Control if folder exists, if not create folder
If Len(Dir("F:\documents\" & Year(Date), vbDirectory)) = 0 Then
MkDir "F:\documents\" & Year(Date)
End If
WordDoc1.SaveAs "F:\documents\" & Year(Date) & "\examplename " & Format(Now, "YYYYMMDD") & ".docx"
WordDoc1.Close
'WordApp1.Quit
Set WordDoc1 = Nothing
Set WordApp1 = Nothing
Windows("exampleworkbook.xlsm").Activate
Sheets("examplesheet").Select
Application.CutCopyMode = False
Range("A1").Select
' export sheet 2 to Word
Sheets("examplesheet2").Select
Set WordApp2 = CreateObject("Word.Application")
WordApp2.Visible = True
WordApp2.Activate
Set WordDoc2 = WordApp2.Documents.Add
Range("A1:C33").Copy
WordApp2.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False
Application.Wait (Now + TimeValue("0:00:02"))
WordDoc2.PageSetup.LeftMargin = CentimetersToPoints(1.5)
WordDoc2.PageSetup.TopMargin = CentimetersToPoints(1.4)
WordDoc2.PageSetup.BottomMargin = CentimetersToPoints(1.5)
WordDoc2.SaveAs "F:\files\" & Year(Date) & "\name" & Format(Now, "YYYYMMDD") & ".docx"
WordDoc2.Close
'WordApp2.Quit
Set WordDoc2 = Nothing
Set WordApp2 = Nothing
Windows("exampleworkbook.xlsm").Activate
Sheets("examplesheet2").Select
Application.CutCopyMode = False
Range("A1").Select
' Variables Outlook
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCc As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach1 As Range
Dim rngAttach2 As Range
Dim numSend As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
' Outlook
On Error GoTo handleError
With Sheets("Mail")
Set rngTo = .Range("B11")
Set rngCc = .Range("B12")
Set rngSubject = .Range("B13")
Set rngBody = .Range("B14")
Set rngAttach1 = .Range("B15")
Set rngAttach2 = .Range("B16")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Cc = rngCc.Value
'.Body = rngBody.Value
.Body = "Hi," & _
vbNewLine & vbNewLine & _
rngBody.Value & _
vbNewLine & vbNewLine & _
"Kind regards,"
.Attachments.Add rngAttach1.Value
.Attachments.Add rngAttach2.Value
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%s"
' .Send ' Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
numSend = numSend + 1
GoTo skipError
handleError:
numErr = numErr + 1
oFile.WriteLine "*** ERROR *** Email for account" & broker & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:
On Error GoTo 0
MsgBox "Sent emails: " & numSend & vbNewLine & "Number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
GoTo endProgram
cancelProgram:
MsgBox "No mails were sent.", vbOKOnly + vbExclamation, "Operation cancelled"
endProgram:
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach1 = Nothing
Set rngAttach2 = Nothing
End Sub
First problem : Run-time error '462' : The remote server machine does not exist or is unavailable.
The issue here is the use of :
Late Biding : Dim Smthg As Object or
Implicit references : Dim Smthg As Range instead of
Dim Smthg As Excel.Range or Dim Smthg As Word.Range
So you need to fully qualified all the variables that you set (I've done that in your code)
Second problem
You work with multiple instances of Word and you only need one to handle multiple documents.
So instead of creating a new one each time with :
Set WordApp = CreateObject("Word.Application")
You can get an open instance (if there is one) or create one with that code :
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0
And once you've put this at the start of your proc, you can use this instance until the end of the proc and before the end, quit it to avoid having multiple instances running.
Here is your code reviewed and cleaned, take a look :
Sub Docs()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
' Control if folder exists, if not create folder
If Len(Dir("F:\documents\" & Year(Date), vbDirectory)) = 0 Then MkDir "F:\documents\" & Year(Date)
' Get or Create a Word Instance
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application")
On Error GoTo 0
Workbooks("exampleworkbook.xlsm").Sheets("examplesheet").Range("A1:C33").Copy
With WordApp
.Visible = True
.Activate
Set WordDoc = .Documents.Add
.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False
End With
With Application
.Wait (Now + TimeValue("0:00:02"))
.CutCopyMode = False
End With
With WordDoc
.PageSetup.TopMargin = WordApp.CentimetersToPoints(1.4)
.PageSetup.LeftMargin = WordApp.CentimetersToPoints(1.5)
.PageSetup.BottomMargin = WordApp.CentimetersToPoints(1.5)
.SaveAs "F:\documents\" & Year(Date) & "\examplename " & Format(Now, "YYYYMMDD") & ".docx"
.Close
End With
' export sheet 2 to Word
Workbooks("exampleworkbook.xlsm").Sheets("examplesheet2").Range("A1:C33").Copy
Set WordDoc = WordApp.Documents.Add
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
Placement:=wdInLine, DisplayAsIcon:=False
Application.Wait (Now + TimeValue("0:00:02"))
With WordDoc
.PageSetup.LeftMargin = WordApp.CentimetersToPoints(1.5)
.PageSetup.TopMargin = WordApp.CentimetersToPoints(1.4)
.PageSetup.BottomMargin = WordApp.CentimetersToPoints(1.5)
.SaveAs "F:\files\" & Year(Date) & "\name" & Format(Now, "YYYYMMDD") & ".docx"
.Close
End With
Application.CutCopyMode = False
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
' Variables Outlook
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim rngTo As Excel.Range
Dim rngCc As Excel.Range
Dim rngSubject As Excel.Range
Dim rngBody As Excel.Range
Dim rngAttach1 As Excel.Range
Dim rngAttach2 As Excel.Range
Dim numSend As Integer
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set objOutlook = CreateObject("Outlook.Application")
On Error GoTo 0
Set objMail = objOutlook.CreateItem(0)
' Outlook
On Error GoTo handleError
With Sheets("Mail")
Set rngTo = .Range("B11")
Set rngCc = .Range("B12")
Set rngSubject = .Range("B13")
Set rngBody = .Range("B14")
Set rngAttach1 = .Range("B15")
Set rngAttach2 = .Range("B16")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.CC = rngCc.Value
'.Body = rngBody.Value
.Body = "Hi," & _
vbNewLine & vbNewLine & _
rngBody.Value & _
vbNewLine & vbNewLine & _
"Kind regards,"
.Attachments.Add rngAttach1.Value
.Attachments.Add rngAttach2.Value
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%s"
' .Send ' Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
numSend = numSend + 1
GoTo skipError
handleError:
numErr = numErr + 1
oFile.WriteLine "*** ERROR *** Email for account" & broker & " not sent. Error: " & Err.Number & " " & Err.Description
skipError:
On Error GoTo 0
MsgBox "Sent emails: " & numSend & vbNewLine & "Number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished"
GoTo endProgram
cancelProgram:
MsgBox "No mails were sent.", vbOKOnly + vbExclamation, "Operation cancelled"
endProgram:
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach1 = Nothing
Set rngAttach2 = Nothing
End Sub
If this is running in Excel then you probably need to specify that CentimetersToPoints is coming from the Word library. As it stands, VBA has to guess and sometimes it probably can't find it. So try:
wdApp.CentimetersToPoints