Create outlook task in non-default folder

[Art Eby]

Hello

I am trying to create outlook tasks in a non-default folder with windows 7 excel 2016. I found some code and adapted it a bit for making tasks, but i get "run-time error '438' object doesn't support this property or method" on this line of the "GetFolderPath" function:

Set oFolder = Application.Session.Folders.Item(FoldersArray(0))

I have the outlook object library reference set. Any help would be appreciated.

[INDENT]
Option Explicit
Public Sub CreateOutlookAppt()
   Sheets("Sheet1").Select
   ' On Error GoTo Err_Execute
      
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.TaskItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim arrCal As Outlook.MAPIFolder
    Dim tzStart As TimeZone, tzEnd As TimeZone
  
    Dim i As Long
          
    On Error Resume Next
  
 Set olApp = Outlook.Application
 Set tzStart = olApp.TimeZones.Item("Eastern Standard Time")
 Set tzEnd = olApp.TimeZones.Item("UTC")
 
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
      
    On Error GoTo 0
      
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = GetFolderPath("\\arthur@sportingvalleyfeeds.com\Tasks")

    i = 1
    Do Until Trim(Cells(i, 1).Value) = ""
     
    Set olAppt = CalFolder.Items.Add(olTaskItem)
            
    With olAppt
      
    'Define calendar item properties
    .Subject = Cells(i, 2)
    .StartDate = Cells(i, 3)
    .DueDate = Cells(i, 4)
    .ReminderTime = 15
    .Status = olTaskNotStarted
    .ReminderSet = True
    .Body = Cells(i, 2)
    .Save
      
    End With
        
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
      
    Exit Sub
      
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
      
End Sub
[/INDENT]

Here is the function:

[INDENT]
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
   
    Dim FoldersArray As Variant
    Dim i As Integer
    Dim oFolder As Outlook.Folder
    
   
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
        
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function
[/INDENT]