VBA to open outlook failing (Working previously).

[coveredinbutter]

Hello everyone,

I have an issue with some workbooks I've created that will take the users input and mail it back. I use the code on multiple different forms and it has worked for years. As of a couple days ago, it now fails with the following error:

Below is the code I'm using up to the point it fails, so

  Set OL = CreateObject("outlook.application")

is no longer working.

Hoping someone has an idea why it is failing all of a sudden. Appreciate any help.

Public Sub Mail_Sheet_Outlook_Body()
    
Set Proxy = Worksheets("Proxy")
Set Locals = Worksheets("Locals")

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    Dim Item As Object
    Dim Send_Address As String

'    With Application
'        .EnableEvents = False
'        .ScreenUpdating = False
'    End With

    'Group Name
    varName1 = Locals.Cells(2, 27).Value
    'Shift Type
    varName2 = Proxy.Cells(9, 7).Value
    'Leader
    varName0 = "Leader Submission"

    Set rng = Nothing
    LastPatternRow = ActiveSheet.Cells(11, 1).End(xlDown).Row
    Set rng = ActiveSheet.Range(Cells(1, 7), Cells(LastPatternRow, 7))
    'old
    'Set rng = ActiveSheet.Range("G1:G301")
    'You can also use a sheet name
    'Set rng = Sheets("YourSheet").UsedRange




    Dim OL, olAllUsers, oExchUser, oentry, myitem As Object
    Dim User As String

    Set OL = CreateObject("outlook.application")
    Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries

 

[davesexcel]

It could not have worked before, your variables are not dim'd correctly.

Dim OL, olAllUsers, oExchUser, oentry, myitem As Object    'not correct

Here is a generic email code you can work with.

Sub SendEmail()
    Dim OutlookApp As Object
    Dim mItem As Object
    Dim Cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Body As String
    Dim cc As String
    Dim bcc As String

    Set OutlookApp = CreateObject("Outlook.Application")

    EmailAddr = Range("B1")
    cc = Range("B2")
    bcc = Range("B3")
    Subj = Range("B4")
    Body = Range("B6")

    Set mItem = OutlookApp.createitem(0)

    With mItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Body
        .cc = cc
        .bcc = bcc
        .display
        ' .send   'use this when you want to send.
    End With

ExitPoint:
    Set OLMsg = Nothing

End Sub

 

[coveredinbutter]

It could not have worked before, your variables are not dim'd correctly.

Dim OL, olAllUsers, oExchUser, oentry, myitem As Object    'not correct

Here is a generic email code you can work with.

Sub SendEmail()
    Dim OutlookApp As Object
    Dim mItem As Object
    Dim Cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Body As String
    Dim cc As String
    Dim bcc As String

    Set OutlookApp = CreateObject("Outlook.Application")

    EmailAddr = Range("B1")
    cc = Range("B2")
    bcc = Range("B3")
    Subj = Range("B4")
    Body = Range("B6")

    Set mItem = OutlookApp.createitem(0)

    With mItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Body
        .cc = cc
        .bcc = bcc
        .display
        ' .send   'use this when you want to send.
    End With

ExitPoint:
    Set OLMsg = Nothing

End Sub

Strange. It had been working and then just stopped. Thank you for this.

 

[coveredinbutter]

I was able to get it working by removing the following two lines:

    '
Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries

Set oentry = olAllUsers.Item(User)

Not sure why they stopped working, but after reviewing, the were unnecessary for what the script need to accomplish.

 

[coveredinbutter]

I Spoke too soon.

I'm using this code in multiple different forms and they all stopped working Saturday. They all use OutlookApp.Session.AddressLists.Item("All Users").AddressEntries to open the address book for verification and for some reason this doesn not work anymore. Is there an alternative way to write this?

                        FT_Outcomes.Cells(User_EmailToMatch, UserColumn) = OutlookMail.SenderName
                            'this checks the name agaist the address book to find the primary email address
                            Set olAllUsers = OutlookApp.Session.AddressLists.Item("All Users").AddressEntries
                            User = OutlookMail.SenderName
                            Set oentry = olAllUsers.Item(User)
                            Set oExchUser = oentry.GetExchangeUser()
                            varActiveEmail = oExchUser.PrimarySmtpAddress
                        FT_Outcomes.Cells(User_EmailToMatch, UserColumn) = varActiveEmail

 

[coveredinbutter]

I re-wrote it like this and it is now up and running.

FT_Outcomes.Cells(User_EmailToMatch, UserColumn) = OutlookMail.SenderName
    'this checks the name agaist the address book to find the primary email address
    'Set olAllUsers = OutlookApp.Session.AddressLists.Item("All Users").AddressEntries
     Set olAllUsers = OutlookNamespace.AddressLists("Global Address List")
     User = OutlookMail.SenderName
     'Set oentry = olAllUsers.Item(User)
      Set oentry = olAllUsers.AddressEntries(User)
      Set oExchUser = oentry.GetExchangeUser()
      varActiveEmail = oExchUser.PrimarySmtpAddress
FT_Outcomes.Cells(User_EmailToMatch, UserColumn) = varActiveEmail