Excel VBA save emails the draft folder of the SentOnBehalfOfName account

[Bering]

Hello,

I would like to add a minor change to the below code. Currently the automatic emails get saved in my personal account in the draft folder. However, I would like them to be saved in the draft folder of the
.SentOnBehalfOfName = "abc@cde.com" account.

I thing I should use .move, but despite several attempts, I have not figure out yet how I should refer to this specific account/folder.

Hope you guys can help me. Thank you

Sub Send_Email_With_Signature()

    Dim objOutApp As Object, objOutMail As Object
    Dim strBody As String, strSig As String
    Dim strLocation, strFileName, strFileExt, pass As String
    Dim StrSignature As String, sPath As String


  
    Set objOutApp = CreateObject("Outlook.Application")
    Set objOutMail = objOutApp.CreateItem(0)
  
    On Error Resume Next
  
    With objOutMail
  
  
        'SET THE EMAIL CONDITIONS
        .To = ActiveSheet.Range("MailDestinataries").Value
        .CC = ActiveSheet.Range("CCMailDestinataries").Value
        .BCC = ""
        .Subject = ActiveSheet.Range("MailSubject").Value
      
        'ADD ATTACHMENTS
         strLocation = ActiveSheet.Range("AttachPath").Value
         strFileName = ActiveSheet.Range("AttachFileName").Value
         strFileExt = ActiveSheet.Range("AttachFileExt").Value
'
        .Attachments.Add strLocation & strFileName & strFileExt
      
      
        'IF SENT FROM ANOTHER EMAIL ACCOUNT (MUST ALREADY BE SETUP)
        .SentOnBehalfOfName = "abc@cde.com"
      
        'CHECK NAMES, ENSURES INTERNAL EMAIL ADDRESSES EXISTS IN ADDRESS BOOK
        .Recipients.ResolveAll
        .Display


        'GET THE HTML CODE FROM THE SIGNATURE
        strSig = .HTMLbody
      
        'CONVERT BODY IN HTML
      
        ActiveSheet.Range("MailBody").Copy
        ActiveSheet.Range("G9").PasteSpecial Paste:=xlPasteValues
        ActiveSheet.Range("H9") = "=fnConvert2HTML(RC[-1])"
      
        strBody = ActiveSheet.Range("H9")
        strBody = "<font style=""font-family: Raleway; font-size: 11pt;""/font>" & strBody
      
        'COMBINE THE EMAIL WITH THE SIGNATURE
      
        .HTMLbody = strBody & vbNewLine & vbNewLine & strSig
      
        'AUTOMATICALLY SAVE EMAIL AS DRAFT (IT WILL STILL BRIEFLY POPUP)
        .Display
        .Save
        .Close 0
        ActiveSheet.Range("G9,H9").ClearContents
  
    End With
  
    On Error GoTo 0
    Set objOutMail = Nothing
    Set objOutApp = Nothing

End Sub

 

[Bering]

Hello,

I fixed it.

Thanks

Sub Send_Email_With_Signature()
 
    Dim objOutApp As Object, objOutMail As Object
    Dim strBody As String, strSig As String
    Dim strLocation, strFileName, strFileExt, pass As String
    Dim StrSignature As String, sPath As String
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objNS As Outlook.Namespace
    
    Set objOutApp = CreateObject("Outlook.Application")
    Set objOutMail = objOutApp.CreateItem(0)
    Set objNS = objOutApp.GetNamespace("MAPI")
    
'    On Error Resume Next
    
    With objOutMail
    
    
        'SET THE EMAIL CONDITIONS
        .To = ActiveSheet.Range("MailDestinataries").Value
        .CC = ActiveSheet.Range("CCMailDestinataries").Value
        .BCC = ""
        .Subject = ActiveSheet.Range("MailSubject").Value
        
        'ADD ATTACHMENTS
         strLocation = ActiveSheet.Range("AttachPath").Value
         strFileName = ActiveSheet.Range("AttachFileName").Value
         strFileExt = ActiveSheet.Range("AttachFileExt").Value
'
        .Attachments.Add strLocation & strFileName & strFileExt
        
        
        'IF SENT FROM ANOTHER EMAIL ACCOUNT (MUST ALREADY BE SETUP)
        .SentOnBehalfOfName = "abc@cde.com"
        
        'CHECK NAMES, ENSURES INTERNAL EMAIL ADDRESSES EXISTS IN ADDRESS BOOK
        .Recipients.ResolveAll
        .Display


        'GET THE HTML CODE FROM THE SIGNATURE
        strSig = .HTMLbody
        
        'CONVERT BODY IN HTML
        
        ActiveSheet.Range("MailBody").Copy
        ActiveSheet.Range("G9").PasteSpecial Paste:=xlPasteValues
        ActiveSheet.Range("H9") = "=fnConvert2HTML(RC[-1])"
        
        strBody = ActiveSheet.Range("H9")
        
       
        strBody = "<font style=""font-family: Raleway; font-size: 11pt;""/font>" & strBody
        
        'COMBINE THE EMAIL WITH THE SIGNATURE
        
        .HTMLbody = strBody & vbNewLine & vbNewLine & strSig
        
        'AUTOMATICALLY SAVE EMAIL AS DRAFT (IT WILL STILL BRIEFLY POPUP)
        .Display
        .Save
        .Close 0
               
        ' Set the destination folders
            Set objDestFolder = objNS.Folders("abc@cde.com").Folders("Drafts")
        
         objOutMail.Move objDestFolder
 
        ActiveSheet.Range("G9,H9").ClearContents
    
    End With
    
    On Error GoTo 0
    Set objOutMail = Nothing
    Set objOutApp = Nothing

End Sub

 

[michfung95]

However, I receive a run-time error '-2147221233 (8004010f)': The attempted operation failed. An object could not be found." at Set objDestFolder = objNS.Folders("abc@cde.com").Folders("Drafts"), may I know how to solve?

 

[Bering]

However, I receive a run-time error '-2147221233 (8004010f)': The attempted operation failed. An object could not be found." at Set objDestFolder = objNS.Folders("abc@cde.com").Folders("Drafts"), may I know how to solve?

You need to change the account name: abc@cde.com was just an example