vba Outlook 日历宏（复制约会）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/1980639/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Outlook Calendar Macro (copy appointments)
提问by tearman
I'm basically trying to figure out how to create a macro in Outlook that allows me to create an appointment with a specific category, that then copies the appointment from the user's local calendar to an Exchange shared calendar (provided it has the right category).
我基本上是想弄清楚如何在 Outlook 中创建一个宏，允许我创建具有特定类别的约会，然后将约会从用户的本地日历复制到 Exchange 共享日历（前提是它具有正确的类别） .
Does anyone have a bit more insight into the Outlook object model on how this would function?
有没有人对 Outlook 对象模型有更深入的了解，了解它的运作方式？
Thanks
谢谢
回答by Fionnuala
Here is some sample code that may help:
以下是一些可能有帮助的示例代码：
Sub CreateCalEntry(LeadDate As Date, DueDate As Date, _
Subject As String, Location As String, Body As String, _
Optional AddToShared As Boolean = True)
Const olApItem = 1
''This example uses late binding, hence object, rather than the commented
''declarations
Dim apOL As Object ''Outlook.Application
Dim oItem As Object ''Outlook.AppointmentItem '
Dim objFolder As Object ''MAPI Folder
Set apOL = CreateObject("Outlook.Application")
''This is the folder to copy to:
Set objFolder = GetFolder("Public Folders/All Public Folders/Shared Calender")
Set oItem = apOL.CreateItem(olApItem) ''See const, above
With oItem
.Subject = Subject
.Location = Location
.Body = Body
.Start = DueDate
If AddToShared = True Then
.Move objFolder
End If
.Display
End With
Set oItem = Nothing
Set apOL = Nothing
End Sub
This allows you to find the shared folder:
这允许您找到共享文件夹：
Public Function GetFolder(strFolderPath As String) As Object 'MAPIFolder
'' strFolderPath needs to be something like
'' "Public Folders\All Public Folders\Company\Sales" or
'' "Personal Folders\Inbox\My Folder"
Dim apOL As Object ''Outlook.Application
Dim objNS As Object ''Outlook.NameSpace
Dim colFolders As Object ''Outlook.Folders
Dim objFolder As Object ''Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set apOL = CreateObject("Outlook.Application")
Set objNS = apOL.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set apOL = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & ": " & Err.Description
End Function
