exportar citas de calendario outlook 2010

buenas

posteo aquí ya que necesito sacar las citas de Outlook 2010 (un calendario compartido concreto) y el destino puede ser cualquier formato de tabla (Excel o Access)

he probado diferentes ejemplos y no me funcionan, parece código oriendato a partir de la versión 2013.

el que más me ayudaría es el del enlace siguiente:

http://www.excelguru.ca/forums/showthread.php?776-Copy-Outlook-Calendar-to-Excel

pero no consigo que funcione

alguien tiene experincia con este tipo de acciones?

Cuando el camino se pone duro, el duro se pone en camino.

el siguiente código funciona.

hay que tener en cuenta que se deben añadir las referencias de outlook, que parece una obviedad, pero a veces pasa.

me encuentro que para el calendario de mi usuario va sin problemas, pero no consigo que funcione con los calendarios que comparten conmigo, que justamente es lo que realmente quiero.

dejo por aquí el código por si puede ayudar a alguien.

pd: en un caso de necesidad he pensado en enviar el excel que funciona con el calendario local y que me lo manden rellenado, pero preferiría poder hacerlo de forma autónoma sin molestar a nadie.

un saludo

Sub Botón1_Clic()

Call GetCalData("01/06/2017", "28/06/2017")

End Sub

Private Function Quote(MyText)

Quote = Chr(34) & MyText & Chr(34)

End Function

Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)

Dim olApp As Outlook.Application

Dim olNS As Outlook.Namespace

Dim myCalItems As Outlook.Items

Dim ItemstoCheck As Outlook.Items

Dim ThisAppt As Outlook.AppointmentItem

Dim MyItem As Object

Dim StringToCheck As String

Dim MyBook As Excel.Workbook

Dim rngStart As Excel.Range

Dim i As Long

Dim NextRow As Long

On Error Resume Next

Set olApp = GetObject(, "Outlook.Application")

If Err.Number <> 0 Then

Set olApp = CreateObject("Outlook.Application")

End If

On Error GoTo 0

If olApp Is Nothing Then

MsgBox "Cannot start Outlook.", vbExclamation

GoTo ExitProc

End If

Set olNS = olApp.GetNamespace("MAPI")

Dim myRecipient As Outlook.Recipient

Set myRecipient = olNS.CreateRecipient("usuarioExchange")

myRecipient.Resolve

Dim calendarFolder As Outlook.Folder

Set calendarFolder = olNS.GetSharedDefaultFolder(myRecipient, olFolderCalendar)

Set myCalItems = calendarFolder.Items

myCalItems.Sort "Start", False

myCalItems.IncludeRecurrences = True

StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & Quote(EndDate & " 11:59 PM")

Debug.Print StringToCheck

Set ItemstoCheck = myCalItems.Restrict(StringToCheck)

Debug.Print ItemstoCheck.Count

If ItemstoCheck.Count > 0 Then

If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc

Set MyBook = ThisWorkbook

Set rngStart = ThisWorkbook.Sheets(1).Range("A1")

With rngStart

.Offset(0, 0).Value = "Convocant"

.Offset(0, 1).Value = "Data inici"

.Offset(0, 2).Value = "Final"

.Offset(0, 3).Value = "Lloc"

End With

For Each MyItem In ItemstoCheck

If MyItem.Class = olAppointment Then

Set ThisAppt = MyItem

NextRow = Range("A" & Rows.Count).End(xlUp).Row

With rngStart

.Offset(NextRow, 0).Value = ThisAppt.Organizer

.Offset(NextRow, 1).Value = ThisAppt.Start

.Offset(NextRow, 2).Value = ThisAppt.End

.Offset(NextRow, 3).Value = ThisAppt.Location

End With

End If

Next MyItem

Columns.AutoFit

Else

MsgBox "There are no appointments or meetings during" & _

"the time you specified. Exiting now.", vbCritical

End If

ExitProc:

Set myCalItems = Nothing

Set ItemstoCheck = Nothing

Set olNS = Nothing

Set olApp = Nothing

Set rngStart = Nothing

Set ThisAppt = Nothing

End Sub

Cuando el camino se pone duro, el duro se pone en camino.

Autor	Mensaje Tema Buscar Opciones del Tema Responder Crear un nuevo tema Versión imprimible Traducir Tema
azezino Ver perfil usuario Enviar mensaje privado Ver los mensajes del usuario Visite la página de los usuarios Añadir a la lista de amigos Habitual Unido: 22/Enero/2007 Localización: España Estado: Sin conexión Puntos: 170	Opciones de entrada Responder Cita azezino Informar de mensaje Gracias(0) Cita Respuesta Tema: exportar citas de calendario outlook 2010 Enviado: 12/Abril/2017 a las 13:03
	buenas posteo aquí ya que necesito sacar las citas de Outlook 2010 (un calendario compartido concreto) y el destino puede ser cualquier formato de tabla (Excel o Access) he probado diferentes ejemplos y no me funcionan, parece código oriendato a partir de la versión 2013. el que más me ayudaría es el del enlace siguiente: http://www.excelguru.ca/forums/showthread.php?776-Copy-Outlook-Calendar-to-Excel pero no consigo que funcione alguien tiene experincia con este tipo de acciones?
	Cuando el camino se pone duro, el duro se pone en camino.

azezino Ver perfil usuario Enviar mensaje privado Ver los mensajes del usuario Visite la página de los usuarios Añadir a la lista de amigos Habitual Unido: 22/Enero/2007 Localización: España Estado: Sin conexión Puntos: 170	Opciones de entrada Responder Cita azezino Informar de mensaje Gracias(0) Cita Respuesta Enviado: 12/Abril/2017 a las 13:16
	quería añadir que en el hilo que pongo, la persona que hace la petición lo quiere para calendario Google pero yo para Exchange, que es en el camino que contesta el amable "Ken Puls". lo máximo que he conseguido, al poner en la casilla mi dirección de correo, es que me capture una sola cita y quiero poder seleccionar un calendario compartido...
	Cuando el camino se pone duro, el duro se pone en camino.

azezino Ver perfil usuario Enviar mensaje privado Ver los mensajes del usuario Visite la página de los usuarios Añadir a la lista de amigos Habitual Unido: 22/Enero/2007 Localización: España Estado: Sin conexión Puntos: 170	Opciones de entrada Responder Cita azezino Informar de mensaje Gracias(0) Cita Respuesta Enviado: 20/Abril/2017 a las 11:56
	el siguiente código funciona. hay que tener en cuenta que se deben añadir las referencias de outlook, que parece una obviedad, pero a veces pasa. me encuentro que para el calendario de mi usuario va sin problemas, pero no consigo que funcione con los calendarios que comparten conmigo, que justamente es lo que realmente quiero. dejo por aquí el código por si puede ayudar a alguien. pd: en un caso de necesidad he pensado en enviar el excel que funciona con el calendario local y que me lo manden rellenado, pero preferiría poder hacerlo de forma autónoma sin molestar a nadie. un saludo Sub Botón1_Clic() Call GetCalData("01/06/2017", "28/06/2017") End Sub Private Function Quote(MyText) Quote = Chr(34) & MyText & Chr(34) End Function Private Sub GetCalData(StartDate As Date, Optional EndDate As Date) Dim olApp As Outlook.Application Dim olNS As Outlook.Namespace Dim myCalItems As Outlook.Items Dim ItemstoCheck As Outlook.Items Dim ThisAppt As Outlook.AppointmentItem Dim MyItem As Object Dim StringToCheck As String Dim MyBook As Excel.Workbook Dim rngStart As Excel.Range Dim i As Long Dim NextRow As Long On Error Resume Next Set olApp = GetObject(, "Outlook.Application") If Err.Number <> 0 Then Set olApp = CreateObject("Outlook.Application") End If On Error GoTo 0 If olApp Is Nothing Then MsgBox "Cannot start Outlook.", vbExclamation GoTo ExitProc End If Set olNS = olApp.GetNamespace("MAPI") Dim myRecipient As Outlook.Recipient Set myRecipient = olNS.CreateRecipient("usuarioExchange") myRecipient.Resolve Dim calendarFolder As Outlook.Folder Set calendarFolder = olNS.GetSharedDefaultFolder(myRecipient, olFolderCalendar) Set myCalItems = calendarFolder.Items myCalItems.Sort "Start", False myCalItems.IncludeRecurrences = True StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & Quote(EndDate & " 11:59 PM") Debug.Print StringToCheck Set ItemstoCheck = myCalItems.Restrict(StringToCheck) Debug.Print ItemstoCheck.Count If ItemstoCheck.Count > 0 Then If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc Set MyBook = ThisWorkbook Set rngStart = ThisWorkbook.Sheets(1).Range("A1") With rngStart .Offset(0, 0).Value = "Convocant" .Offset(0, 1).Value = "Data inici" .Offset(0, 2).Value = "Final" .Offset(0, 3).Value = "Lloc" End With For Each MyItem In ItemstoCheck If MyItem.Class = olAppointment Then Set ThisAppt = MyItem NextRow = Range("A" & Rows.Count).End(xlUp).Row With rngStart .Offset(NextRow, 0).Value = ThisAppt.Organizer .Offset(NextRow, 1).Value = ThisAppt.Start .Offset(NextRow, 2).Value = ThisAppt.End .Offset(NextRow, 3).Value = ThisAppt.Location End With End If Next MyItem Columns.AutoFit Else MsgBox "There are no appointments or meetings during" & _ "the time you specified. Exiting now.", vbCritical End If ExitProc: Set myCalItems = Nothing Set ItemstoCheck = Nothing Set olNS = Nothing Set olApp = Nothing Set rngStart = Nothing Set ThisAppt = Nothing End Sub
	Cuando el camino se pone duro, el duro se pone en camino.