Código VBA para convertir una instancia de una cita recurrente de Outlook en una no recurrente

In Herramientas y formatos, Todas by RicardoLeave a Comment

Cuando se realiza seguimiento al calendario de Outlook y se analiza para ver en qué se está invirtiendo el tiempo, las citas que son recurrentes no son tomadas en cuenta en los cálculos.

Para convertir una instancia de una cita recurrente en una no recurrente y superar este problema, se puede copiar este código en un módulo de Outlook VBA y asignarlo a un botón en la cinta de opciones de citas recurrentes.

Adaptado del código de Diane Poremsky
http://www.slipstick.com/developer/copy-recurring-appointments-meetings-series/

 Sub ConvertRecurring()
    
    Dim CalFolder As Outlook.MAPIFolder
    Dim CalItems As Outlook.Items
    Dim ResItems As Outlook.Items
    Dim sFilter, strSubject As String
    Dim iNumRestricted As Integer
    Dim newAppt As Object
    Dim recAppt As Object
    
    ' Use the selected calendar folder
    Set CalFolder = Application.ActiveExplorer.CurrentFolder
    
    Set recAppt = Application.ActiveExplorer.Selection.Item(1)
    
    ' Validate if it's a recuurring appointment
    If recAppt.IsRecurring = False Then
        MsgBox "Seleccione una cita recurrente"
        Exit Sub
    End If
    
    Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
    
    newAppt.Start = recAppt.Start
    newAppt.End = recAppt.End
    newAppt.Subject = recAppt.Subject
    newAppt.Body = recAppt.Body
    newAppt.Location = recAppt.Location
    newAppt.Categories = recAppt.Categories
    newAppt.ReminderSet = False
    
    ' Copies attachments to each appointment.
    If recAppt.Attachments.Count > 0 Then
        CopyAttachments recAppt, newAppt
    End If
        
    newAppt.Save
    
    recAppt.Delete

    
    ' Display the actual number of appointments created
    MsgBox "Se convirtió la instancia de la cita recurrente"
    
    Set newAppt = Nothing
    Set ResItems = Nothing
    Set CalItems = Nothing
    Set CalFolder = Nothing
    
End Sub
 
Sub CopyAttachments(objSourceItem, objTargetItem)
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
   strPath = fldTemp.Path & "\"
   For Each objAtt In objSourceItem.Attachments
      strFile = strPath & objAtt.FileName
      objAtt.SaveAsFile strFile
      objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
      fso.DeleteFile strFile
   Next
 
   Set fldTemp = Nothing
   Set fso = Nothing
End Sub

Leave a Comment