将约会添加到非默认日历

Question

I know there's additional stuff in the Declarations, it's for other macros I've written.

I've several calendars. I've a spreadsheet where I paste information about a site, and I've buttons that generate appointments and emails.

I've code to set an appointment, however it goes to my main calendar. I'm trying to get the appointment onto my other calendars. I've read about MAPI functions, but can't get it to work. The location is \\myemail@me.com\\Calendar. Name of the calendar is SVN Calendar.

    Dim olApp As Outlook.Application9
    Dim olEmail As Outlook.MailItem
    Dim olCal As Outlook.AppointmentItem
    Dim olFolder As Outlook.Folder
    Dim RequiredAttendee, OptionalAttendee, ResourceAttendee As Outlook.Recipient
    Dim rtf() As Byte

    Dim rngTo As Range
    Dim rngCC As Range
    Dim rngSUB As Range
    Dim rngCALloc As Range
    Dim rngCALstart As Range
    Dim rngCALend As Range
    Dim rngBody As Range
    Dim myItem As Object

    Sub newTestCreateCalendarUSA1()
    'Testing calendar to other calendar than main.
    ' i.e. SVN Calendar.  can't identify the actual calendar.

    Set olApp = New Outlook.Application
    Set m = olApp.CreateItem(olMailItem)
    Set appt = olApp.CreateItem(olAppointmentItem)
    
    With ActiveSheet
        Set rngCC = .Range("I34")
        Set rngCALloc = .Range("I5")
        Set rngCALstart = .Range("I11")
        Set rngCALend = .Range("I12")
        Set rngSUB = .Range("I33")
        Set rngSite = .Range("C2")
        Set rngLoc = .Range("C4")
        Set rngTYPE = .Range("B23")
        Set rngGON = .Range("C23")
        Set rngPurpose = .Range("C21")
        Set rngGoals = .Range("C22")
        Set rngDate = .Range("I1")
        Set rngDateStart = .Range("I8")
        Set rngDateEnd = .Range("I9")
        Set rngTime = .Range("I10")
        Set rngCAS = .Range("C26")
    End With
    
    MsgBox "Ensure all attendees are correct prior to sending invite."
            
    appt.MeetingStatus = olMeeting
    appt.RequiredAttendees = rngCC.Value
    appt.Subject = rngSUB.Value
    appt.Location = rngCALloc.Value
    appt.Start = rngCALstart.Value
    appt.End = rngCALend.Value
    appt.AllDayEvent = True
    m.BodyFormat = olFormatHTML
    m.HTMLBody = Range("I31").Value
    m.GetInspector().WordEditor.Range.FormattedText.Copy
    appt.GetInspector().WordEditor.Range.FormattedText.Paste
    appt.Display
    m.Close False

End Sub

Edit: Thanks for directing me to follow the folder tree. I tried understanding the GetNameSpace thing, but couldn't get it to work.

I did find a different code and got it to make an appointment on the correct calendar.

Sub SVN_Calendar_Invite()
    'trial run of SVN Calendar with other code
    Dim oApp As Object
    Dim oNameSpace As Namespace
    Dim oFolder As Object
 
    Set oApp = New Outlook.Application
    Set oNameSpace = oApp.GetNamespace("MAPI")
    Set oFolder = oNameSpace.GetFolderFromID("0000000098F32312526B334EAEC97D94705E33FB0100C964D8D325E3554DA24A72FB876E3F600001912394000000")

    With ActiveSheet
        Set rngCC = .Range("I34")
        Set rngCALloc = .Range("I5")
        Set rngCALstart = .Range("I11")
        Set rngCALend = .Range("I12")
        Set rngSUB = .Range("I33")
        Set rngSite = .Range("C2")
        Set rngLoc = .Range("C4")
        Set rngTYPE = .Range("B23")
        Set rngGON = .Range("C23")
        Set rngPurpose = .Range("C21")
        Set rngGoals = .Range("C22")
        Set rngDate = .Range("I1")
        Set rngDateStart = .Range("I8")
        Set rngDateEnd = .Range("I9")
        Set rngTime = .Range("I10")
        Set rngCAS = .Range("C26")
    End With

    With oFolder
        Set olApt = oApp.CreateItem(olAppointmentItem)
        With olApt
            .AllDayEvent = True
            .RequiredAttendees = rngCC.Value
            .Start = rngDateStart.Value
            .End = rngDateEnd.Value
            .Subject = rngSUB.Value
            .Location = rngLoc.Value
            .Body = "The body of your appointment note"
            .BusyStatus = olFree
            .Save
            .Move oFolder
        End With
        Set olNS = Nothing
        Set olApp = Nothing
        Set olApt = Nothing
    End With

End Sub

I've these problems now.
1- if I use .Display to bring up the calendar item to review it, it doesn't display.
2- even though it's an all day event, and the cells are 3 days apart, it subtracts the end date by 1 day.
3- I have to manually invite the attendees, which defeats the purpose of doing this invite.

Answer 1

ok so im about two years late. found this thread while i was facing the same problem. manage to solve with some trial and error so, this works for me. so you might give it a try for future pple who are googling for the same ans...

a lil more info is i did not set reference to Outlook under tools cos i have many user files.

---

'start

'break down here retype cos stackoverflow format xxx

Sub Add_Appt_to_Main_Sub_Calendar()

Dim BOOK2 As Workbook
    Workbooks.Open Filename:= _
    "Name of your file.csv"

    'csv is readable by outlook but not excel, u need to change the file type first

    
   'start pulling data from your csv file here
    
'if you are not setting reference to outlook under tools, please define all your outlook names as Object
    
  Dim olAppts As Object
  Dim Calfolder As Object
'this to define the main calendar folder
  Dim Subfolder As Object
'this to define the sub calendar folder

    Set olApp = CreateObject("Outlook.Application")

    Set olNamespace = olApp.GetNamespace("MAPI")
    
Dim filter As Variant
'cos we dont want to keep import duplicate appt into outlook calendar so we need to create and define a filter

Dim olfolder As Object
'the folder picker by user

Dim strolFolder As String
' we want to get the name of the folder picker by user    
     
    Set olfolder = olApp.GetNamespace("MAPI").Pickfolder
    'olfolder.Display
    'how to find the name of the folder selected

    On Error Resume Next
    
    If olfolder = "" Then
    MsgBox "No calendar selected."
    
    Workbooks("Name of your file.csv").Close savechanges:=True
   'close the csv file if no calendar selected by user
    
    
    
    Exit Sub
    
    Else
    
     strolFolder = olfolder
'name of the file pick by user

     Set Calfolder = olNamespace.GetDefaultFolder(9)
'defaultfolder(9) is the main calendar by default tagged to user outlook acc
     strCalfolder = Calfolder
     'name of the sub folder

    MsgBox strolFolder
    MsgBox strCalfolder
    MsgBox (olfolder.folderpath)
    MsgBox (Calfolder.folderpath)
     'keep for debugging
     
     If olfolder.folderpath <> Calfolder.folderpath Then
    
    
    'this is the line that add appointment into sub calendar
     
    Set olAppts = olNamespace.GetDefaultFolder(9).Folders(strolFolder)
    'eg. Set olAppts = olNamespace.GetDefaultFolder(9).Folders("name of subfolder")
    
    
   'this is the main folder
    Set Calfolder = olNamespace.GetDefaultFolder(9)
    'MsgBox Calfolder
    
    'this is the sub folder i want to add in
    Set Subfolder = Calfolder.Folders(strolFolder)
    
    'MsgBox Subfolder
    
    'add appt to subfolder
    Set olAppt = Subfolder.items.Add
    
    'MsgBox (olfolder.EntryID)
    'MsgBox (olfolder)
    'MsgBox (olfolder.FolderPath)
    'keep for debugging

    r = 2
    Do Until Trim(Cells(r, 1).Value) = ""
    
        'filter by subject, start date and location
        'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
        'On Error Resume Next 'enable error-handling machine
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
        'Set olAppt = olAppts.items.Find(filter)
        'currently this does a check in your main calendar
        'if existing appointment based on subject, start date and location is not found, add appointment
        ' i need to do a search in the subcalendar instead of main calendar
        
        Set olAppt = olAppts.items.Find(filter)
        
        If TypeName(olAppt) = "Nothing" Then
            
            
            Set myAppt = Subfolder.items.Add
            'Set myAppt = olApp.CreateItem(1)
            'if using main use create, if use subfolder add
            
            myAppt.Subject = Cells(r, 2).Value
            myAppt.Location = Cells(r, 8).Value
            myAppt.Start = Cells(r, 7).Value
            myAppt.Categories = Cells(r, 3).Value
            myAppt.Duration = 120
            myAppt.BusyStatus = 2
            myAppt.ReminderSet = True
            myAppt.Body = Cells(r, 11).Value
            myAppt.Save
        End If

        r = r + 1
        
    Loop
        
            
    MsgBox "TCU added to sub calendar."
     'if picked folder is sub calendar

     Else
     
   Set olApp = CreateObject("Outlook.Application")
        
        strCalfolder = olNamespace.GetDefaultFolder(9)
        Set olNamespace = olApp.GetNamespace("MAPI")
        Set olAppts = olNamespace.GetDefaultFolder(9)
    
        r = 2
        Do Until Trim(Cells(r, 1).Value) = ""
    
        'filter by subject, start date and location
        'filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        'filter = "[Subject] = '" & Replace(Cells(r, 2).Value, "'", "''") & "' and [Start] = '" & Format(Cells(r, 7).Value, "dddd Hn:Hn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
            On Error Resume Next 'enable error-handling machine
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Cells(r, 8).Value & "'"
        
        
        filter = "[Subject] = '" & Cells(r, 2).Value & "' and [Start] = '" & Format(Cells(r, 7).Value, "ddddd Hh:Nn") & "' and [Location] = '" & Replace(Cells(r, 8).Value, "'", "''") & "'"
        
        Set olAppt = olAppts.items.Find(filter)
        
        'if existing appointment not found, add appointment
            If TypeName(olAppt) = "Nothing" Then
                Set myAppt = olApp.CreateItem(1)
                myAppt.Subject = Cells(r, 2).Value
                myAppt.Location = Cells(r, 8).Value
                myAppt.Start = Cells(r, 7).Value
                myAppt.Categories = Cells(r, 3).Value
                myAppt.Duration = 120
                myAppt.BusyStatus = 2
                myAppt.ReminderSet = True
                myAppt.Body = Cells(r, 11).Value
                myAppt.Save
            End If

            r = r + 1
        
            Loop
    MsgBox "TCU added to main calendar."

    End If


End If

   
    'end add appt

    'close ur csv file
    Workbooks("Name of your file.csv").Close savechanges:=True
    
End Sub