• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 517
  • Last Modified:

From field OUTLOOK VBA

I need to send an email using vba on behalf of another mailbox. How can I tweak the code below to accomplish this?




Public Sub CreateAnEmail_Corp(filename As String, FullName As String, RecipentEmail As String, SupervisorEmail As String)
On Error Resume Next
Dim db As Database
Dim rs As Recordset
Dim ClientEmail As String
Dim DisplayMsg As Boolean
Dim AttachmentPath As String
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim objOutlookExplorers As Outlook.Explorers
Dim myarray() As String
Dim myaddresses() As String
Dim x As Integer
Dim fs As Object
Dim BuiltPath As String
Dim response As Integer
Dim WasOpen As Boolean


DisplayMsg = True
'AttachmentPath = "J:\data\" & ReportCaption & ".pdf"

If EnoughPrompts = 0 Then
MsgBox "The email is about to be created!" & vbCrLf & _
        "If nothing appears to be happening, the Outlook security box may be hiding behind an open window." & vbCrLf & _
        "Click the Outlook icon on the taskbar to bring it to the front, if necessary."
End If
EnoughPrompts = 1


Set objOutlook = GetObject(, "Outlook.Application")
'MsgBox Err.Number & " " & Err.Description
If Err.Number = 429 Then
    Err.Clear
    WasOpen = False
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    
Else
    WasOpen = True
End If
    Dim ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder
    Set ns = objOutlook.GetNamespace("MAPI")
    Set Folder = ns.GetDefaultFolder(olFolderInbox)
    Set objOutlookExplorers = objOutlook.Explorers
    
If WasOpen = False Then
    objOutlook.Explorers.Add Folder
    Folder.Display
    'done opening
End If

AppActivate "Microsoft Outlook"

' Create the message.
'Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
   
    'can't do this, the mail never gets sent
    ' Add the from recipient(s) to the message.
    'Set objOutlookRecip = .Recipients.Add(somebody)
    'objOutlookRecip.Type = olOriginator
    
    ' Add the CC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add(RecipentEmail)
    objOutlookRecip.Type = olto
        
    ' Add the CC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add(SupervisorEmail)
    objOutlookRecip.Type = olCC

   ' Add the BCC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("Kelly")      objOutlookRecip.Type = olBCC
    
   ' Set the Subject, Body, and Importance of the message.
   .Subject = "Notice of File"

    .BodyFormat = olFormatHTML
   .HTMLBody = "<p>" & FullName & "," & "</P>"
   .HTMLBody = .HTMLBody & "The attached Notice to File is being placed in your Personnel File for failure to complete your required training by the due date. <br><br>"
   .HTMLBody = .HTMLBody & "Please <a href = 'http://www.google.com'>CLICK HERE</a> to take your courses immediately.   This training is mandatory and critical to ensure you are aware of important Company policies and procedures. <br><br>"
   .HTMLBody = .HTMLBody & "In the future, failure to complete your Compliance training by the due date may lead to disciplinary action, up to and including termination. <br><br>"
   .HTMLBody = .HTMLBody & "Thank you,<br><br>"
   .HTMLBody = .HTMLBody & "Training Team"
   
   ' Add attachments to the message.
   'reportcaption is passed in and split into myarray
   'one attachment needs to be added for each element in myarray

        AttachmentPath = "J:\data\" & filename
    If Not IsMissing(AttachmentPath) Then
        Set objOutlookAttach = .Attachments.Add(AttachmentPath)
    End If

            
   ' Resolve each Recipient's name.
   For Each objOutlookRecip In .Recipients
       objOutlookRecip.Resolve
   Next

   ' Should we display the message before sending?
   If DisplayMsg Then
       .Display
   Else
       .Save
       .Send
   End If
End With


Set objOutlook = Nothing

End Sub

Open in new window







0
kwarden13
Asked:
kwarden13
  • 3
  • 2
2 Solutions
 
darbid73Commented:
Here is the code you need to have before you start with your email.  Many of these objects you have already set so you need to decide how you want to do this;

Basically at the very least you can put this right before you start with objOutlookMsg.

email.address@goes.here needs to be the email address of the shared email.

I have tried to follow your namings but may have missed something.

Set objOutlookRecip = ns.CreateRecipient(email.address@goes.here)

objOutlookRecip.Resolve   'this will show the outlook security message

If objOutlookRecip Is Nothing Then
    msgbox "Problem"
End If

Set Folder = ns.GetSharedDefaultFolder(objOutlookRecip, olFolderInbox)

If objFolder Is Nothing Then
    Msgbox "Problem"
End If

Set objOutlookMsg = Folder.Items.Add

Open in new window

0
 
kwarden13Author Commented:
It didn't work
0
 
darbid73Commented:
what did not work?
0
 
kwarden13Author Commented:
Its ok I got it to work with just adding 1 line

 objOutlookMsg.SentOnBehalfOfName = "Email Address"
Thanks though
0
 
kwarden13Author Commented:
My solution works best.
0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now