Outlook Calendar Macro (copier des rendez-vous)

Question

Je suis en train d'essayer de comprendre comment créer une macro dans Outlook qui me permet de créer un rendez-vous avec une catégorie spécifique, puis copie le rendez-vous du calendrier local de l'utilisateur vers un Exchange calendrier partagé (à condition qu'il ait la bonne catégorie).

Quelqu'un a-t-il un peu plus d'informations sur le modèle d'objet Outlook sur la façon dont cela fonctionnerait?

Merci

Answer 1

Voici quelques exemples de code qui peut aider:

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 

Cela vous permet de trouver le dossier partagé:

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