Consulting

Results 1 to 2 of 2

Thread: Sending MS Project task to Outlook as an appoitnment in a custom calendar

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Newbie
    Joined
    Feb 2024
    Posts
    1
    Location

    Sending MS Project task to Outlook as an appoitnment in a custom calendar

    I came across this macro which is working fine thus far. What it does is that it sends a task in MS Project to MS Outlook as a new appointment to add to my Outlook calendar.

    Sub Export_Selection_To_OL_Appointments()Dim myTask As Task
    Dim myItem As Object
        
    On Error Resume Next
    Set myOLApp = CreateObject("Outlook.Application")
      
    For Each myTask In ActiveSelection.Tasks
        Set myItem = myOLApp.CreateItem(1)
        With myItem
            .Start = myTask.Start
            .End = myTask.Finish
            .Subject = " Rangebank PS " & myTask.Name
            .Categories = myTask.Project
            .Body = myTask.Notes
            .Save
        End With
    Next myTask
    
    
    
    End Sub


    The code currently creates an appointment in my default Calendar but I wanted for it to create an appointment within a different calendar with a different name. I sought help else where and was provided this as a way to reference a non default calendar, which is below

    Option Explicit
    
    Sub NonDefaultFolder_Add_Not_Create()
    
    
    Dim myOlApp As Object
    Dim myDefaultStore As Object
    
    
    Dim nonDefaultCalendar As Object
    Dim myItem As Object
    
    
    On Error Resume Next
    Set myOlApp = CreateObject("Outlook.Application")
    
    
    ' Consider this mandatory.
    ' Limit the scope of the error bypass to the minimum number of lines.
    ' Ideally the scope is zero lines.
    On Error GoTo 0
    
    
    If Not myOlApp Is Nothing Then
    
    
        Set myDefaultStore = myOlApp.Session.defaultStore
        Debug.Print myDefaultStore
        
        ' This references a calendar on the same level as the default calendar
        Set nonDefaultCalendar = myOlApp.Session.Folders(myDefaultStore.DisplayName).Folders("Calendar Name")
        nonDefaultCalendar.Display
        
        ' Add to non-default folders (or create in the default then copy or move)
        Set myItem = nonDefaultCalendar.Items.Add
        With myItem
            .Subject = " Rangebank PS "
            .Display
        End With
    
    
    Else
        MsgBox "Error creating Outlook object."
        
    End If
    
    
    
    End Sub


    I am very much a novice and wassnt sure where I was supposed to add the above into the original code so I tried this.

    Option Explicit
    
    Sub NonDefaultFolder_Add_Not_Create()
    Dim myTask As Task
    Dim myItem As Object
    Dim myOLApp As Object
    Dim myDefaultStore As Object
    Dim nonDefaultCalendar As Object
    On Error Resume Next
    Set myOLApp = CreateObject("Outlook.Application")
      
    For Each myTask In ActiveSelection.Tasks
        Set myItem = myOLApp.CreateItem(1)
        With myItem
            .Start = myTask.Start
            .End = myTask.Finish
            .Subject = " Rangebank PS " & myTask.Name
            .Categories = myTask.Project
            .Body = myTask.Notes
            .Save
    
    
    
    
    On Error GoTo 0
    
    
    If Not myOLApp Is Nothing Then
    
    
        Set myDefaultStore = myOLApp.Session.DefaultStore
        Debug.Print myDefaultStore
        
        
        Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")
        nonDefaultCalendar.Display
        
        ' Add to non-default folders (or create in the default then copy or move)
        Set myItem = nonDefaultCalendar.Items.Add
        With myItem
            .Subject = " Rangebank PS "
            .Display
        End With
        End If
    
    
    End With
    
    End Sub


    Ive highlighted the original code in blue and the name of the custom calendar in red. But this doesnt work as I get this error


    "Run-time error '-2147221233 (8004010f)': The attempted operation failed. An Object could not be found.


    It highlights this as the error

    Set nonDefaultCalendar = myOLApp.Session.Folders(myDefaultStore.DisplayName).Folders("B2A Projects Calendar")
    If it helps this is where the B2A project Calendar appears in outlook

    calendr.jpg

    So its a calendar I created and then I share it with my other team members.

    Any help would be greatly appreciated!

    Thanks

  2. #2
    VBAX Master
    Joined
    Jul 2006
    Location
    Belgium
    Posts
    1,285
    Location
    I don't have project so I couldn't test this but you can loop through the code with F8 to see what needs fixing.
    Use it in a testing phase first.
    Sub Export_Selection_To_OL_Appointments()
    'project variables
    'I used object because I don't have project
        Dim myTask As Object
    'outlook variables
        Dim myOLApp As Object
        
        Dim Ns As Object
        Dim folder As Object
        Dim appt As Object
            
    'setting up outlook for appointment in shared calendar
    'myOLApp = outlook
    'ns = outlooknamespace environment
        Set myOLApp = CreateObject("Outlook.Application")
        Set Ns = myOLApp.GetNamespace("MAPI")
    'the shared calendar is part of your default calendar = folder of folder
    'B2A Projects Calendar = name of shared calendar ?
        Set folder = Ns.GetDefaultFolder(olFolderCalendar).Folders("B2A Projects Calendar")
    'appointment should be added to shared calendar
    'so for every task in your selection we make an appointment in shared calendar
        For Each myTask In activeselection.Tasks
            Set appt = folder.items.Add
            With appt
                .Start = myTask.Start
                .End = myTask.Finish
                .Subject = " Rangebank PS " & myTask.Name
                .Categories = myTask.Project
                .Body = myTask.Notes
                .Display 'or .Save
            End With
            'clear the appt variable to accept new values for next myTask
            Set appt = Nothing
        Next myTask
    'clear up variables
    myOLApp = Nothing
    End Sub
    Charlize

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •