MMM13
08-17-2017, 07:43 AM
Hi,
Newbie here;
I have the below code that emails the contacts within the excel spreadsheet, with attachments.
I am trying to use a Word object in excel to edit the content of the email body, which then converts to HTML when the macro runs for it to be used in the email body keeping its format.
At the moment, the code opens the email for preview and the content in the Word object is not in the email body, the name of the word object does however appear in the email body.
Any help is appreciated.
Thanks in advance!
Sub Send_Files()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim objDoc As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("TestingSheet") 'Use "TestingSheet" for actual tests, "Test" for actually sending the emails
WordTxt ("C:") '<======= Change to suit
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row/
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.BodyFormat = olFormatHTML
.To = cell.Value
.Subject = "" <=====enter subject
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.HTMLBody = WordToOutlook(rng)
'.Attachments.Add ("File full path")
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display
'.Send
End With
Set objInspector = OutApp.ActiveInspector
If Not objInspector Is Nothing And objInspector.EditorType = olEditorWord Then
Set objDoc = objInspector.WordEditor
objDoc.Range.Paste
End If
End If
Set OutMail = Nothing
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Public Function WordToOutlook(ByVal rng As Range)
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".doc"
Set selectRange = rng
Set WDObj = ThisWorkbook.ActiveSheet.OLEObjects("ProjectAccuracy")
WDObj.Activate
WDObj.Object.Application.Visible = True
Set WDApp = GetObject(, "Word.Application")
Set WDDoc = WDApp.ActiveDocument
'Save as HTML
WDDoc.SaveAs TempFile, FileFormat:=8
WDDoc.Close savechanges:=False
WDApp.Quit
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Application.DisplayAlerts = True
Set WDDoc = Nothing
Set WDApp = Nothing
Set oEmbFile = Nothing
Kill TempFile
Set ts = Nothing
Set fso = Nothing
'Return Value
WordToOutlook = RangetoHTML
End Function
Newbie here;
I have the below code that emails the contacts within the excel spreadsheet, with attachments.
I am trying to use a Word object in excel to edit the content of the email body, which then converts to HTML when the macro runs for it to be used in the email body keeping its format.
At the moment, the code opens the email for preview and the content in the Word object is not in the email body, the name of the word object does however appear in the email body.
Any help is appreciated.
Thanks in advance!
Sub Send_Files()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim objDoc As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("TestingSheet") 'Use "TestingSheet" for actual tests, "Test" for actually sending the emails
WordTxt ("C:") '<======= Change to suit
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row/
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*@?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.BodyFormat = olFormatHTML
.To = cell.Value
.Subject = "" <=====enter subject
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.HTMLBody = WordToOutlook(rng)
'.Attachments.Add ("File full path")
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display
'.Send
End With
Set objInspector = OutApp.ActiveInspector
If Not objInspector Is Nothing And objInspector.EditorType = olEditorWord Then
Set objDoc = objInspector.WordEditor
objDoc.Range.Paste
End If
End If
Set OutMail = Nothing
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Public Function WordToOutlook(ByVal rng As Range)
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".doc"
Set selectRange = rng
Set WDObj = ThisWorkbook.ActiveSheet.OLEObjects("ProjectAccuracy")
WDObj.Activate
WDObj.Object.Application.Visible = True
Set WDApp = GetObject(, "Word.Application")
Set WDDoc = WDApp.ActiveDocument
'Save as HTML
WDDoc.SaveAs TempFile, FileFormat:=8
WDDoc.Close savechanges:=False
WDApp.Quit
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Application.DisplayAlerts = True
Set WDDoc = Nothing
Set WDApp = Nothing
Set oEmbFile = Nothing
Kill TempFile
Set ts = Nothing
Set fso = Nothing
'Return Value
WordToOutlook = RangetoHTML
End Function