Excel创建一个Outlook日历事件

Question

您可以从Excel中运行一个可以与Outlook进行交互并在日历上创建和事件的宏吗？

Answer 1

只要您有权写入共享日历，就可以在任何文件夹中添加约会。

款待日历作为文件夹

Const olFolderInbox = 6 
Const olAppointmentItem = 1 '1 = Appointment 

Set objOutlook = CreateObject("Outlook.Application") 
Set objNamespace = objOutlook.GetNamespace("MAPI") 
'Finds your Inbox 
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox) 

'Gets the parent of your Inbox which gives the Users email 
strFolderName = objInbox.Parent 
Set objCalendar = objNamespace.Folders("Public folders - " & strFolderName).Folders("SubFolder1").Folders("subfolder of subfolder 1").Folders("Your Calendar") 

Set objapt = objCalendar.Items.Add(olAppointmentItem) 
objapt.Subject = "Test" 'Owner 
objapt.Start = Date + TimeValue("08:00:00") 
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both) 
objapt.End= Date + TimeValue("16:00:00") 
objapt.Save 

Answer 2

对对方的回答略有改善，从蒂姆commment

Sub createappt() 

Const olFolderCalendar = 9 
Const olAppointmentItem = 1 '1 = Appointment 

Set objOutlook = CreateObject("Outlook.Application") 

'Set objOutlook = GetObject(, "Outlook.Application") ' outlook already open 
Set objNamespace = objOutlook.GetNamespace("MAPI") 
Set Items = objNamespace.GetDefaultFolder(olFolderCalendar).Items 

Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder") 
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender 
Set objapt = objCalendar.Items.Add(olAppointmentItem) 
objapt.Subject = "Test" 'Owner 
objapt.Start = Date + TimeValue("08:00:00") 
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both) 
objapt.End = Date + TimeValue("16:00:00") 
objapt.Save 
End Sub 

Answer 3

链接 - http://excelexperts.com/Creating-appointments-for-outlook-in-VBA

Sub AddAppointments2() 
    ' Create the Outlook session 
    Set myOutlook = CreateObject("Outlook.Application") 

    ' Start at row 2 
    r = 2 

    Do Until Trim(Cells(r, 1).Value) = "" 
     For Each olapt In olFldr.Items 
      If TypeName(myApt) = "AppointmentItem" Then 
       If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then 
        myApt.Body = appt.Body & Cells(r, 2) 
        myApt.Save 
       Else 
        ' Create the AppointmentItem 
        Set myApt = myOutlook.createitem(1) 
        ' Set the appointment properties 
        myApt.Subject = Cells(r, 1).Value 
        myApt.Location = Cells(r, 2).Value 
        myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00") 
        myApt.Duration = Cells(r, 5).Value 
        ' If Busy Status is not specified, default to 2 (Busy) 
        If Trim(Cells(r, 6).Value) = "" Then 
         myApt.BusyStatus = 2 
        Else 
         myApt.BusyStatus = Cells(r, 6).Value 
        End If 
        If Cells(r, 7).Value > 0 Then 
         myApt.ReminderSet = True 
         myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value 
        Else 
         myApt.ReminderSet = False 
        End If 
        myApt.Body = Cells(r, 12).Value 
        myApt.Save 
        r = r + 1 
       End If 
      End If 
     Next olapt 
    Loop 
End Sub 

下面是其他链接https://stackoverflow.com/a/49121400/4539709