Acitve X component can’t create object

[ThrottleWorks]

Hi,

I am facing an issue while creating an e-mail item from Excel VBA.
This particular code is working fine at my system.

However facing issues at user’s desk while trying to create e-mail.
I have copied the code for creating e-mails for Ron De Bruin’s site.
And this code is working fine for me in numerous macros.
Not able to understand why there are issues at user’s desk.
I have also checked, References- VBAProject, it is ticked for ‘Microsoft Office 14.0 Object Library’ at user’s desk also.

I tried using Shell (“Outlook”) before writing
Set OutAppp = CreateObject(“Outlook.Application”)
But still somehow e-mail is not getting created.

Can anyone please help me in this.

Sub Prepare_Email()
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As Variant

Set MacroBook = ThisWorkbook
Set EmailSht = MacroBook.Worksheets("Email Mapping")
Set Rng = Nothing
Set Rng = EmailSht.Range("O1:V20")
'Shell ("Outlook")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
.Display
End With

Signature = OutMail.body
EmailSht.Range("D2") = "Test"
EmailSht.Range("O3") = "Test"

With OutMail
.To = EmailSht.Range("B2")
.CC = EmailSht.Range("C2")
.Subject = EmailSht.Range("D2")
.HTMLBody = RangetoHTML(Rng) & Signature
.Display
End With

Set OutMail = Nothing
Set OutApp = Nothing
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"
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

On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

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

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=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

 

[Chihiro]

Have a read of link and step through your code on user's desk to debug.
https://support.microsoft.com/en-us...ror-429-when-you-automate-office-applications