Error Message: Run-time error '287': Application-defined or object-defined error

[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 would be much appreciated!!

Thank you!!
Rosie