Question

我有一个脚本可以从SharePoint站点获取实验室中断数据。根据某些条件，如果发生中断，它会向Outlook发送约会。

Private Sub CreateAppt(Subject As String, startTime As Date, endTime As Date, _
  startDate As Date, endDate As Date, superString As String, _
  OUTAGEREQUIRED As String)
Dim body As String:
Dim myoutlook As Outlook.Application
Dim myRecipient As Outlook.Recipient
Dim myNameSpace As Outlook.Namespace
Dim olkCalendar As Object
Dim olkSession As Object
Dim myapt As Object ' Outlook.AppointmentItem
'Dim r As Long

' late bound constants
Const olAppointmentItem = 1
'Const olBusy = 2
Const olMeeting = 1

    ' Create the Outlook session
    'On Error GoTo meetingFailed
    Set myoutlook = Outlook.Application 'CreateObject("Outlook.Application")
    Set olkSession = myoutlook.Session
    Set myNameSpace = myoutlook.GetNamespace("MAPI")
    Set myRecipient = myNameSpace.CreateRecipient("***@.com")
    'Create the AppointmentItem
    'On Error GoTo meetingFailed
    Set myapt = myoutlook.CreateItem(olAppointmentItem)
    olkSession.Logon
    Set olkCalendar = olkSession.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    ' Set the appointment properties
    With myapt
        .Subject = Subject
        .body = superString
        .Start = startDate & " " & startTime
        .End = endDate & " " & endTime
        .MeetingStatus = olMeeting
        .ReminderSet = True
        .ReminderMinutesBeforeStart = "5"
        'Conditional check -> if outageRequired is true then
        ' set BusyStatus to Busy and Color to red
        If (OUTAGEREQUIRED = True) Then
        .BusyStatus = 2
        .Categories = "Red Category"
        'Conditional check -> if OutageRequired is false then
        ' set BusyStatus to Free and Color to Blue
        ElseIf (OUTAGEREQUIRED = False) Then
        .BusyStatus = 0
        .Categories = "Blue Category"
        End If
        'Send emails to hardcoded email addresses
        'Primary email address is ******@***.com
        If Not DEBUGCODE Then
            .Recipients.Add "****@.com"
        Else
            .Recipients.Add "***@.com"
        End If
            .Recipients.ResolveAll
        .Save
        .Send
    End With
Exit Sub

它将实验室停机详细信息发送到我的个人Outlook日历。

有没有办法将详细信息发送到共享日历？

Answer 1

添加到非默认文件夹。

Set olkCalendar = olkSession.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
Set myapt = olkCalendar.Items.Add
With myapt
    …
    .Save
    ' Send
End With

将约会发送到共享日历

1 个答案: