Macro to send outlook email from a different mailbox

**naveenrv** · 03-25-2013, 03:00 PM

Hi there,

I'm trying to write VBA code to send email from a shared mailbox to which I have full permissions. The below VBA code sends email from the primary outlook account, but I've been unable to send from a different mailbox address("From" field) configured on the same account. I've tried ".SendUsingAccount" and ".SendonBehalfofName", but those are used in the case of different outlook accounts altogether. Please advise. Here's the code.

Dim ws         As Worksheet
Dim olApp       As Outlook.Application
Dim mailbody    As String
Dim iR        As Long
Dim strbody As String, strbody1 As String, strBody2 As String, strBody3 As String
Dim strbody4 As String, strbody5 As String, strBody6 As String, strfirst As String
Dim strbody8 As String, strbody9 As String, strBody10 As String, strBody11 As String
Dim strBody14 As String, strBody15 As String
Dim trackURL As String
Dim trackURL2 As String


    Set olApp = New Outlook.Application

    For Each ws In ActiveWorkbook.Worksheets
        With ws
        mailbody = "<TABLE Border=""1"", Cellspacing=""0""><TR>" & _
 "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">Application*</p></Font></TD>" & _
    "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">User ID*</p></Font></TD>" & _
 "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">Firstname*</p></Font></TD>" & _
    "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">Middlename*</p></Font></TD>" & _
       "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">LastName*</p></Font></TD>" & _
       "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">Department*</p></Font></TD>" & _
          "<TD Bgcolor=""#2B1B17"", Align=""Center""><Font Color=#FCDFFF><b><pstyle=""font-size:18px"">Positionnumber*</p></Font></TD>" & _
                       "</TR>"
            For iR = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                mailbody = mailbody & "<TR>" & _
                           "<TD><center>" & .Cells(iR, "A").Value & "</TD>" & _
                           "<TD><center>" & .Cells(iR, "B").Value & "</TD>" & _
                           "<TD><center>" & .Cells(iR, "C").Value & "</TD>" & _
                           "<TD><center>" & .Cells(iR, "D").Value & "</TD>" & _
                           "<TD><center>" & .Cells(iR, "E").Value & "</TD>" & _
                           "<TD><center>" & .Cells(iR, "F").Value & "</TD>" & _
                           "<TD><center>" & .Cells(iR, "G").Value & "</TD>" & _
                           "</TR>"
            Next iR

            With olApp.CreateItem(olMailItem)
                trackURL = "<a href=""http://requestmanager.pfizer.com"">Request Manager</a>"
                trackURL2 = "<a href=""http://pdocsanon/pdocsanon/component/getcontent?objectId=0901179d8017d7ca&chronicleId=0901179d8005f96e&status=Effective"">Form10</a>"
                strfirst = ws.Range("H2").Value
                strbody = "Hello " & strfirst & "," & "<br>"
                strbody1 = "You have been identified as a manager with a resource " & _
                "who recently had a department/position change and has access to a PGS application."
                strBody2 = "<B>What actions do you need to take?</B>"
                strBody11 = "   1) Review  the PGS account list below."
                strBody3 = "    2) Take the following action for each resource:"
           strbody4 = "<DD> a)  If the level of access <b> does not </b> need to change and account is still needed no action is required from you."
                strbody5 = "b)  If the role change requires any change in access please access " & trackURL & _
                " to submit an account change or revoke the account.&nbsp;&nbsp;If you require assistance please contact your local BT group.</DD>"
                strBody6 = "    3)  If the resource resides within PGS-BT, please work with the resource and previous manager to submit a " & trackURL2 & _
                " to PLS within two business days."
                strBody14 = "Thank you in advance for helping keep PGS in compliance!"
                strBody15 = "- PGS-BT Account Management"
                
'-- Formulas
                Msg = strbody & "<br>" & strbody1 & "<br>" & "<br>" & strBody2 & "<br>" & strBody11 & "<br>" & strBody3 & "<br>" & _
                strbody4 & "<br>" & strbody5 & strBody6 & "<br>" & "<br>" & _
                strBody14 & "<br>" & "<br>" & strBody15 & "<br>" & "<br>"
                '.From = "PGS Account Review"
                .To = ws.Range("K2").Value
                .CC = "PGSAccountReview@pfizer.com"
                .Subject = "Action Requested - PGS Access Review After Worker Dept/Position Change "
                .HTMLBody = "<FONT color=#000000 face=Calibri size=3>" & Msg & mailbody & "</Table>"
                '.Display
                .Send
            End With
        End With
    Next ws
End Sub

**judgeh59** · 03-25-2013, 03:15 PM

this is what I use to email from another user that I admin....you can see some fields to fill in and it's make a call to an HMTL converter function...you can change the object htmlbody to body and put a string in there to be the body of the email....if you need the html converter let me know...HTH

Sub SendEmail(MyName, Rpt2)
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010

    Dim EmailTo As String, FileDir As String, EmailCC As String, EmailBCC As String
    Dim objmessage As Object
    Dim i As Integer, LastRow As Integer
    Dim rng As Range
    
    LastRow = Cells(65000, 1).End(xlUp).Row
    Set rng = Range("A1:H" & LastRow)

    EmailTo = MyName
    EmailCC = Rpt2

    Set objmessage = CreateObject("CDO.Message")
    objmessage.Subject = "Training Notice - DO NOT REPLY TO THIS EMAIL"
    objmessage.From = "insert user name "
    objmessage.To = ""
    objmessage.CC = ""
    objmessage.BCC = ""

    objmessage.htmlBody = RangetoHTML(rng)
    objmessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objmessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "INSERT YOUR SMTP SERVER NAME HERE"
    objmessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    objmessage.Configuration.Fields.Update
    objmessage.Send

End Sub

**naveenrv** · 03-25-2013, 05:07 PM

Thanks for the suggestion Ernest. I should've started by saying this: I'm a noob when it comes to VBA. I did modify your code in a number of ways, but couldn't get it to run correctly. This is probably a little too much to ask, but could you modify my original code to allow for the "from" address to be the mailbox address (say ABC is the mailbox name and ABC@xyz.com is the "FROM" email address)? Thanks a lot.

**judgeh59** · 03-25-2013, 05:11 PM

give this a try....

Sub SendEmail()

    Dim EmailTo As String, FileDir As String, EmailCC As String, EmailBCC As String
    Dim objmessage As Object
    Dim i As Integer, LastRow As Integer
    Dim rng As Range

    Set objmessage = CreateObject("CDO.Message")
    objmessage.Subject = "Training Notice - DO NOT REPLY TO THIS EMAIL"
    objmessage.From = "billjoejimbob@mywork.com"
    objmessage.To = "ABC@xyz.com"
    objmessage.CC = "somebody@abc.com"
    objmessage.BCC = ""

    objmessage.Body = "This is the body of the message"
    objmessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objmessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "ENTER YOUR SMTP SERVER HERE"
    objmessage.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    objmessage.Configuration.Fields.Update
    objmessage.Send

End Sub