Crear Cita en calendario de Outlook desde Excel
Tengo una macro que al ejecutarse me crea una cita en el calendario de mi cuenta personal en Outlook. Ahora bien, en mi ordenador tengo configurada otra cuenta a la que tenemos acceso varias personas y me gustaría que la cita se creara en dicho calendario para que le saliera a todas las personas con acceso a dicha cuenta de Outlook.
He probado con .SendUsingAccount y no me realiza nada.
Adjunto código de la macro.
Sub CrearCita()
Dim oAPP As New Outlook.Application
Dim ns As Outlook.Namespace
Dim cita As Outlook.AppointmentItem
Dim Titulo As String
Dim TransRowRng As Range
Dim NewRow As Integer
Dim FechaInicio As Date
Dim FechaFin As Date
Dim Oficina As String
Titulo = "Seguimiento ScrowAccount"
'---------------------------------------------------------------------
FechaInicio = ScrowAccount.TextBox2.Value
FechaFin = ScrowAccount.TextBox5.Value
Oficina = ScrowAccount.TextBox6.Value
'---------------------------------------------------------------------
Set TransRowRng = ThisWorkbook.Worksheets("Tareas").Cells(1, 1).CurrentRegion
NewRow = TransRowRng.Rows.Count + 1
With ThisWorkbook.Worksheets("Tareas")
.Cells(NewRow, 1).Value = ScrowAccount.Asunto.Value
.Cells(NewRow, 2).Value = ScrowAccount.TextBox2.Value
.Cells(NewRow, 3).Value = ScrowAccount.TextBox5.Value
.Cells(NewRow, 5).Value = ScrowAccount.TextBox4.Value
.Cells(NewRow, 6).Value = ScrowAccount.TextBox6.Value
End With
If ScrowAccount.CheckBox1 = False Then
Set oAPP = GetOutlookApp
If oAPP Is Nothing Then
MsgBox "No se puede iniciar Outlook.", vbInformation, Titulo
Unload ScrowAccount
Exit Sub
End If
Set ns = oAPP.GetNamespace("MAPI")
Set cita = oAPP.CreateItem(olAppointmentItem)
With cita
.Subject = ScrowAccount.Asunto.Value
.Start = FechaInicio
.Duration = 180 'cambiar este parámetro si queremos que dure más o menos la cita
.Body = ScrowAccount.TextBox4.Value
.Importance = olImportanceHigh
.Location = "Ordinal oficina:" + " " + Oficina
'.SendUsingAccount = "[email protected]"
.Save
End With
Else
End If
MsgBox "Aviso creado con éxito.", vbInformation, Titulo
Unload ScrowAccount
Exit Sub
End Sub
1 Respuesta
Va codigo 1ºparte
Sub AñadirCitas_a_Calendario_Outlook()
'trasladamos citas desde Excel hacía el Calendario de Outlook
Dim olApp As Object
Dim olNs As Object
Dim olCarpetas As Object, olSubcarpetas As Object
Dim olCalendarios As Object
Dim objCita As Object
Dim sh As Worksheet
Dim i As Long, UF As Long
On Error Resume Next
Va codigo 2ºparte
'Creamos el objeto para la aplicación MS Outlook y abrimos
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
'determinamos cuál es la última fila con datos
Set sh = Sheets("xlsCalendario")
UF = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
If Not olApp Is Nothing Then
'Inicia una sesión de usuario en MAPI
Set olNs = olApp.GetNamespace("MAPI")
olNs.LogOn
'buscamos, con el doble bucle, entre todas las carpetas de Outlook
'y entre todos los Calendarios existentes el que se llame 'Excelforo'
For Each olCarpetas In olNs.Folders
For Each olSubcarpetas In olCarpetas.Folders
'
If olSubcarpetas.Name = "Calendario" Then
For Each olCalendarios In olSubcarpetas.Folders
'con el nombre de nuestro Calendario!!
If olCalendarios.Name = "TodoExpertos" Then
'y recorremos todos los datos de la hoja de cálculo
For i = 2 To UF
'Generamos una nueva cita
Set objCita = olCalendarios.Items.Add(1)
'y la completamos con la info de la hoja en Excel
With objCita
'el Asunto
.Subject = sh.Range("A" & i).Value
'la Hora de Inicio
Va codigo 4ºparte
'el Texto o Cuerpo de la cita
.Body = sh.Range("F" & i).Value
'la Ubicación de la cita
.Location = sh.Range("G" & i).Value
'la categoría que le asignamos
.Categories = sh.Range("H" & i).Value
'Mostrar como: 0-Disponible, 1-Provisional, 2-Ocupado, 3-Fuera de la oficina o 4-Trabajando en otro lugar
.BusyStatus = sh.Range("I" & i).Value
'si activamos una cita de Todo el día
.AllDayEvent = sh.Range("J" & i).Value
'. ReminderSet = True 'si queremos tener activa el recordatorio (15 minutos antes, por defecto)
.Save 'guardamos la cita
End With
Next i
'si hemos dado en el bucle con el Calendario buscado
'salimos de éste (dejamos de buscarlo)
Exit For
End If
Next olCalendarios
End If
Next olSubcarpetas
Next olCarpetas
End If
'liberamos memoria de los objetos definidos
Set olApp = Nothing
Set olNs = Nothing
Set olStore = Nothing
Set olCal = Nothing
Set objAppt = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Me rindo compañero, intente de mil maneras pero esta web no deja enviar códigos con muchos símbolos =/
Aquí te dejo una web donde puedes ver un ejemplo
Agregar cita a calendario Outlook
Espero una buena valoración por mi esfuerzo! Je je
