|
Responder ![]() |
Autor | |
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: 173 |
![]() 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: 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: 173 |
![]() |
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: 173 |
![]() |
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.
|
|
![]() |
Responder ![]() |
|
Tweet
|
Ir al foro | Permisos de foro ![]() Usted No puede publicar nuevos temas en este foro Usted No puede responder a temas en este foro Usted No puede borrar sus mensajes en este foro Usted No puede editar sus mensajes en este foro Usted No puede crear encuestas en este foro Usted No puede votar en encuestas en este foro |