Outlook日历宏（复制约会）

Question

我基本上想弄清楚如何在Outlook中创建一个宏，允许我创建与特定类别的约会，然后将约会从用户的本地日历复制到Exchange共享日历（只要它有正确的类别）。

有没有人对Outlook对象模型有多了解？

感谢

Answer 1

下面是一些示例代码，可以帮助：

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 

这可以让你找到共享文件夹：

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