Outlook Calendar Macro (назначения копирования)

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