VBA - Generate Email with Attachment (Runtime Error)

[tomexcel1]

Hi All

I have the following code that essentially generates an email with the current file as an attachment. It keeps coming up with a runtime error on the highlighted line below. I just cant seam to fix it, the code is in a user form if that makes any difference.

The Error is: Run-Time error '429' ActiveX component can't create object

Any help will be much appreciated!

Private Sub CommandButton1_Click()

If Sheet11.Range("D83") > 0 Then
CONFIRM = MsgBox("Please fill in all fields before submitting", vbOKOnly + vbExclamation, "MISSING INFORMATION!")
Else

            Application.ScreenUpdating = False
            Application.EnableEvents = False
            
            Sheet2.Unprotect ("password")
            Sheet2.Range("A1").Select
            Range("D39").Value = Environ("UserName")
            Range("G39").Value = Now
            Range("D38").Value = Environ("UserName")
            Range("G38").Value = Now
            
            ActiveSheet.Shapes("CommandButton1").Visible = False
            ActiveSheet.Shapes("CommandButton3").Visible = True
            ActiveSheet.Shapes("CommandButton4").Visible = True
            Sheet2.Protect ("password")
            Sheet11.Range("AK2").Value = TeamName.Text
  
  
Dim wb1 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object


    Set wb1 = ActiveWorkbook

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "File NAME -" & " " & Sheet2.Range("D9").Value & " - " & Format(Now, "dd.mm.yy h.mm")
    FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
    
    strsubject = "Subject Name - " & Sheet2.Range("D9").Value & " - " & Sheet2.Range("D8").Value & " " & Sheet2.Range("G8")
    strbody = "Body Text"
    strto = Sheet11.Range("AK3").Value & "@email.co.uk"
    wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr

 [COLOR=rgb(226, 80, 65)]  [/COLOR][B][COLOR=rgb(226, 80, 65)] Set OutApp = CreateObject("Outlook.Application")[/COLOR][/B]
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = strto
        .CC = ""
        .BCC = ""
        .Subject = strsubject
        .Body = strbody
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .display
    End With
    On Error GoTo 0

    'Delete the file
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Unload Me
End If
End Sub

 

[Domenic]

Have a look at the following link...

https://support.microsoft.com/en-ca/help/828550/you-receive-run-time-error-429-when-you-automate-office-applications