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