[英]Automatically send outlook appointment to someone else's calendar from excel
[英]Export outlook calendar meeting and appointment for today's date
請參閱下面的代碼。 我無法獲取今天日期和日歷約會的代碼。
Option Explicit
Private Sub Workbook_Open()
On Error GoTo ErrHand:
Application.ScreenUpdating = False
'This is an enumeration value in context of getDefaultSharedFolder
Const olFolderCalendar As Byte = 9
Dim olapp As Object: Set olapp = CreateObject("Outlook.Application")
Dim olNS As Object: Set olNS = olapp.GetNamespace("MAPI")
Dim olfolder As Object
Dim olApt As Object: Set olNS = olapp.GetNamespace("MAPI")
Dim objOwner As Object: Set objOwner = olNS.CreateRecipient("s.prabhuboazgnanaraj@asianpaints.com")
Dim NextRow As Long
Dim olmiarr As Object
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
objOwner.Resolve
If objOwner.Resolved Then
Set olfolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")
'Ensure there at least 1 item to continue
If olfolder.items.Count = 0 Then Exit Sub
'Create an array large enough to hold all records
Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olfolder.items.Count - 1)
'Add the records to an array
'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
On Error Resume Next
For Each olApt In olfolder.items
myArr(0, NextRow) = olApt.Subject
myArr(1, NextRow) = olApt.Start
myArr(2, NextRow) = olApt.End
myArr(3, NextRow) = olApt.Location
NextRow = NextRow + 1
Next
On Error GoTo 0
'Write all records to a worksheet from an array, this is much faster
ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)
'AutoFit
ws.Columns.AutoFit
cleanExit:
Application.ScreenUpdating = True
Exit Sub
ErrHand:
'Add error handler
Resume cleanExit
End Sub
您可以在今天的日期之前使用限制項目。 日歷文件夾比郵件文件夾更棘手。
Option Explicit
Sub restrictCalendarEntryByDate()
Dim Counter As Long
Dim olkItems As Items
Dim olkSelected As Items
Dim olkAppt As AppointmentItem
Dim dateStart
Dim dateEnd
Dim StrFilter As String
dateStart = Date
dateEnd = Date + 1 ' Note this day will not be in the time period
'dateStart = "2017-10-30"
'dateEnd = "2017-10-31" ' Note this day will not be in the time period
If IsDate(dateStart) And IsDate(dateEnd) Then
Set olkItems = Session.GetDefaultFolder(olFolderCalendar).Items
olkItems.IncludeRecurrences = True
olkItems.Sort "Start"
StrFilter = "[Start] >= '" & Format(dateStart, "ddddd h:nn AMPM") & "'"
Debug.Print StrFilter
Set olkSelected = olkItems.Restrict(StrFilter)
StrFilter = StrFilter & " AND [Start] < '" & Format(dateEnd, "ddddd h:nn AMPM") & "'"
Debug.Print StrFilter
Set olkSelected = olkItems.Restrict(StrFilter)
For Each olkAppt In olkSelected
Counter = Counter + 1
Debug.Print Counter & ":" & olkAppt.Subject & " " & olkAppt.location & olkAppt.start
Next
End If
End Sub
您可以從 Outlook 獲取今天的約會 try if(olkAppt.Start==DateTime.Now.Date)
For Each olkAppt In olkSelected
Counter = Counter + 1
if(olkAppt.Start==DateTime.Now.Date)
{
Debug.Print Counter & ":" & olkAppt.Subject & " " & olkAppt.location & olkAppt.start
}
Next
您可以使用以下腳本通過 Excel 設置您想要的任何約會。
Sub AddAppointments()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")
' Start at row 2
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
' 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, 3).Value
myApt.Duration = Cells(r, 4).Value
' If Busy Status is not specified, default to 2 (Busy)
If Trim(Cells(r, 5).Value) = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = Cells(r, 5).Value
End If
If Cells(r, 6).Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
Else
myApt.ReminderSet = True
End If
myApt.Body = Cells(r, 7).Value
myApt.Save
r = r + 1
Loop
End Sub
設置看起來像這樣。 . .
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.