Keep getting error Message: Run-time error '287': Application-defined or object-defi

[RosieG1991]

Hey guys

I use a spread sheet with a macro built by someone who left my team a year or so ago - Up until now I've had no issues with the Macro.
The macro pulls data from a mailbox in Outlook when you click a button within the spread sheet. We have recently moved to Windows 10 and I've been advised that this was when the macro has stopped working. Could the move to Windows 10 be causing an issue with the Macro or could it be something else? I'm not 100% certain if someone else in my team has tried to fix this macro before coming to me.
Please see below the section of the marco that is getting highlighted when I click the 'Debug' button in the error msg:

Sub ExportToExcel()


'On Error GoTo ErrHandle
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim workbookFile As String
Dim msg As Outlook.MailItem
Dim nms As Outlook.Namespace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim irow As Integer
Dim olApp As Object
Dim iSender As String
Dim iLast As Integer


iLast = Sheets("ACTIVE").Range("C" & Rows.Count).End(xlUp).Row
Set olApp = CreateObject("Outlook.Application")
'Select export folder
Set nms = olApp.Application.GetNamespace("MAPI")
Set fld = nms.Folders("Selections").Folders("Inbox")


'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If


'Open and activate Excel workbook.


Set wks = Sheets("ACTIVE")
wks.Activate
Application.Visible = True


'Copy field items in mail folder.


For Each itm In fld.Items


irow = wks.Range("A" & Rows.Count).End(xlUp).Row + 1
If itm.Class = Outlook.OlObjectClass.olMail Then
Set msg = itm
If msg.SentOn > wks.Range("A" & iLast).Value Then
wks.Range("D" & irow) = msg.Subject
wks.Range("A" & irow) = msg.SentOn
wks.Range("B" & irow) = msg.SentOn
wks.Range("F" & irow) = msg.SenderName
wks.Range("H" & irow) = ResolveDisplayNameToSMTP(msg.SenderName)


iSender = wks.Range("F" & irow).Value
iTable = Sheets("ContactLIst").Range("Contacts")
If wks.Range("H" & irow) = "" Then
iformula = Application.VLookup(iSender, iTable, 3, False)
If IsError(iformula) Then
wks.Range("H" & irow) = ""
Else
wks.Range("H" & irow) = iformula
End If
End If
If wks.Range("H" & irow) = "" Then
wks.Range("H" & irow) = msg.SenderEmailAddress
End If
End If
End If

Next

Call AddDep


irow = Sheets("ACTIVE").Range("A" & Rows.Count).End(xlUp).Row


Sheets("ACTIVE").Range("A" & iLast & ":H" & irow).Sort key1:=Sheets("ACTIVE").Range("A" & iLast), order1:=xlAscending, Header:=xlNo


Sheets("ACTIVE").Range("A" & iLast & ":H" & irow).NumberFormat = "dd/mm/yyyy"
Sheets("ACTIVE").Range("B" & iLast & ":H" & irow).NumberFormat = "h:mm"

Set appExcel = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Set olApp = Nothing

irow = 0
End Sub



Function ResolveDisplayNameToSMTP(sFromName)
Dim oRecip As Outlook.Recipient
Dim oEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")

Set oRecip = olApp.Application.Session.CreateRecipient(sFromName)

oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress '+ vbCrLf + oEU.BusinessTelephoneNumber
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress '+ vbCrLf + oEU.BusinessTelephoneNumber
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress '+ vbCrLf + oEU.BusinessTelephoneNumber
End If
End Select
End If
End Function ' ResolveDisplayNameToSMTP



Sub AddDep()


Dim irow As Integer
Dim iLast As Integer
Dim wks As Excel.Worksheet


Set wks = Sheets("ACTIVE")


iLast = Sheets("ACTIVE").Range("C" & Rows.Count).End(xlUp).Row
irow = wks.Range("A" & Rows.Count).End(xlUp).Row
For i = iLast To irow
iSender = wks.Range("F" & i).Value
iTable = Sheets("ContactLIst").Range("Contacts")
If wks.Range("G" & i) = "" Then
iformula = Application.VLookup(iSender, iTable, 2, False)
If IsError(iformula) Then
Else
wks.Range("G" & i) = iformula
End If
End If
Next i
End Sub

Any help trying to fix this marco/figure out why I'm getting the error msg would be much appreciated!!
Could it be the move to Windows 10?

Thank you!!
Rosie

[Kenneth Hobs]

Welcome to the forum! Please paste code between code tags so we can see structure. Click # icon on reply toolbar to insert the tags.

1. Put Option Explicit as the first line of code as the first line of code in a Module or Userform.
2. In Visual Basic Editor (VBE) Compile code before a Run. It is in the Debug menu.
3. Fix missing variables where Type was not set in Dim.
4. All variables that will return a row number, make sure that it is type Long. Integers are not big enough for some big row numbers.
5. Why to columns for SendOn?
6. Since the next line after the error calls a function, try commenting the error line out to see if it runs. Even if the SendName was empty it should not have erred. I have not used SendName so I will look at that. Exchange can do some odd things.
a. If this works, try using On Error Resume Next earlier in the code.

I will look at this a bit more. Some parts I may not be able to test. As is, even if it did run without error, it could be very slow.

[Aflatoon]

I think that's an Outlook security issue. Your code will need to be trusted to run.

[RosieG1991]

How do I trust the code for it to run?
I've been advised by my IT dept that it's an issue with moving to Outlook 2016.
I'm not quite sure how to re-trust the code or alter the code slightly to work with the newer version of Outlook?

[Kenneth Hobs]

Did you check Tools > References, to make sure that the newer version of Outlook is selected?

In Outlook, File > Options > Trust Center is where you set security. Likely, IT has locked you from changing it.

You could try adding a certificate to the code.

[dhancy]

Hello,


I am facing a similar issue with the '287' issue. In my case, it's happening on the oRecip.Resolve line. The first thing I noticed is that it's changing this line to oRecip.resolve (lowercase resolve).


When I step through the code, it stops on this line with the '287' error code.


We are using Office 2016.


Two "Trust Center" images are attached: one from Excel and one from Outlook.


Any suggestions are greatly appreciated.


Thanks!


Dennis2667126672