[英]Add appointment to a non-default calendar
我知道声明中有其他内容,它用于我编写的其他宏。
我有几个日历。 我有一个电子表格,用于粘贴有关站点的信息,还有用于生成约会和电子邮件的按钮。
我有设置约会的代码,但是它会转到我的主日历。 我正在尝试将约会添加到我的其他日历中。 我已阅读有关 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-我必须手动邀请与会者,这违背了进行此邀请的目的。
好的,所以我晚了大约两年。 当我面临同样的问题时发现了这个线程。 设法通过一些试验和错误来解决,所以这对我有用。 所以你可以为未来在谷歌上搜索相同答案的人试一试......
更多信息是我没有在工具下设置对 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.