將約會添加到非默認日歷

Question

我知道聲明中有其他內容，它用於我編寫的其他宏。

我有幾個日歷。 我有一個電子表格，用於粘貼有關站點的信息，還有用於生成約會和電子郵件的按鈕。

我有設置約會的代碼，但是它會轉到我的主日歷。 我正在嘗試將約會添加到我的其他日歷中。 我已閱讀有關 MAPI 函數的信息，但無法使其正常工作。 位置是\\myemail@me.com\\Calendar。 日歷的名稱是 SVN 日歷。

    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

編輯：感謝您指導我遵循文件夾樹。 我試圖理解 GetNameSpace 的東西，但無法讓它工作。

我確實找到了一個不同的代碼，並讓它在正確的日歷上進行約會。

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

我現在有這些問題。
1- 如果我使用.Display出日歷項目來查看它，它不會顯示。
2- 即使這是一個全天事件，並且單元格相隔 3 天，它也會將結束日期減去 1 天。
3-我必須手動邀請與會者，這違背了進行此邀請的目的。

Answer 1

好的，所以我晚了大約兩年。 當我面臨同樣的問題時發現了這個線程。 設法通過一些試驗和錯誤來解決，所以這對我有用。 所以你可以為未來在谷歌上搜索相同答案的人試一試......

更多信息是我沒有在工具下設置對 Outlook 的引用，因為我有很多用戶文件。

---

'開始

'在這里分解重新輸入 cos stackoverflow 格式 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