Runtime error #429 Active X component can't create object

Sub Email()

    '   Declare Variables for file and macro setup
    Dim UserName As String
    Dim MailDbName As String
    Dim Maildb As Object
    Dim MailDoc As Object
    Dim AttachME As Object
    Dim Session As Object
    Dim EmbedObj1 As Object
    Dim Attachment As String
    Dim Title As String
    Title = Range("H11")
    
    
    'Added into from Exchange
    
    'Dim OutApp As Outlook.Application
    'Dim OutMail As Outlook.MailItem
    Dim OutApp As Object
    Dim OutMail As Object
    Dim wb As Workbook
    Dim strdate As String
    
    
    ' End of Exchange Addition
    
    
       
    ActiveWorkbook.Save
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
    
    'Sheets("Sheet1").Visible = True
     '   Application.Goto Reference:="Sheet1"
    
    
    '   Name attachment
    Attachment = "C:\Temp\Quote.xls"
    
    ' Making new sheet to eliminate hidden fields
    
    Range("A10:L218").Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    'ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:="C:\temp\Quote.xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    'ActiveWindow.Close
    
    
    
    
    
    
    
    
    
    
    With ActiveWorkbook
        .SaveAs Attachment, FileFormat:=xlNormal
    End With
        
    yesno = MsgBox(" This will generate an e-mail." _
           & vbCrLf & " Do you wish to send this Quote request?" _
    , vbYesNo + vbInformation, "E-mail this Quote?")
    
    Select Case yesno
        Case vbNo
        Exit Sub
    End Select
    Select Case yesno
        Case vbYes
    
    
    'Added into from Exchange
    
    Set wb = ActiveWorkbook
        With wb
            '.SaveAs "Part of " & ThisWorkbook.Name _
             ' & " " & strdate & ".xls"
             
              .SaveAs Title
             
             
            Set OutApp = CreateObject("Outlook.Application")
            'Set OutMail = OutApp.CreateItem(olMailItem)
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = "someone@somewhere.com"
                .CC = ""
                .BCC = ""
                .Subject = "A quote for " & Title
            .Body = Replace("Please see the email attachment regarding my Quote request:@@" _
            & Join(Application.Transpose(Range([H3], [H3].End(3))), "@") _
                    & "@@Thank you!", "@", vbCrLf)
        .Attachments.Add wb.FullName
        .Send   'or use .Display
            End With
            .ChangeFileAccess xlReadOnly
            Kill .FullName
        .Close False
    End With
    
            
            
  ' Added to try to eliminate the pause after clicking yes to sending
            
        '.Close False
       

 
 
       
        

    
       
    
        
        
        
        
    
    '   Open and locate current LOTUS NOTES User
'    Set Session = CreateObject("Notes.NotesSession")
'        UserName = Session.UserName
'            MailDbName = Left$(UserName, 1) & Right$(UserName, _
'            (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
'    Set Maildb = Session.GETDATABASE("", MailDbName)
'        If Maildb.IsOpen = True Then
'            Else
'                Maildb.OPENMAIL
'        End If
'
    '   Create New Mail and Address Title Handlers
'    Set MailDoc = Maildb.CREATEDOCUMENT
    
'    MailDoc.Form = "Memo"
'    Recipient = "Lonnie.Hull@usfood.com"
'        MailDoc.SendTo = Recipient
'        MailDoc.CopyTo = Array("A1")
'            MailDoc.Subject = Title
'MailDoc.Body = _
'    Replace("Please see the email attachment regarding my Quote request:@@" _
'            & Join(Application.Transpose(Range([H13], [H13].End(3))), "@") _
'                    & "@@Thank you!", "@", vbCrLf)
'Replace("Please see the email attachment regarding my Quote request:@@" _
'           & Join(Application.Transpose(Range([B17], [B36].End(3))), "@") _
'                    & "@@Thank you!", "@", vbCrLf)


    '   Select Workbook to Attach to E-Mail
'    MailDoc.savemessageonsend = True
'        attachment1 = Attachment
    
'    If attachment1 <> "" Then
'        On Error Resume Next
'            Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
'            Set EmbedObj1 = AttachME.embedobject(1454, "attachment1", _
'            Attachment, "")
'        On Error Resume Next
'    End If
    
'    MailDoc.PostedDate = Now()
'        On Error GoTo errorhandler1
'    MailDoc.Send 0, Recipient
    
'    Set Maildb = Nothing
 '   Set MailDoc = Nothing
  '  Set AttachME = Nothing
   ' Set Session = Nothing
    'Set EmbedObj1 = Nothing
    
      ' Routine to Generate a copy if required
    OnOff = MsgBox("Do you want to save a copy?", _
   vbYesNo + vbInformation, "Save Copy?")
    
   Select Case OnOff
       Case vbNo
           ActiveWorkbook.Close
       Exit Sub
   End Select
       Select Case OnOff
    
   Case vbYes
       Set NewBook = ActiveWorkbook
            Do
               fName = Application.GetSaveAsFilename
          Loop Until fName <> False
       NewBook.SaveAs Filename:=fName
   ActiveWorkbook.Close
    
    End Select
    ActiveWorkbook.Close
    '   Kill the temp file here if necessary
    Kill Attachment
    
    Exit Sub
    
errorhandler1:

    Set OutMail = Nothing
    Set OutApp = Nothing
    Set Maildb = Nothing
    Set MailDoc = Nothing
    Set AttachME = Nothing
    Set Session = Nothing
    Set EmbedObj1 = Nothing
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
   End Select
ActiveWorkbook.Close
  'End With
End Sub