StillUnderstanding
Board Regular
- Joined
- Jan 30, 2021
- Messages
- 80
- Office Version
- 365
- Platform
- Windows
- MacOS
Hello,
I am running the below code to create a calendar appointment but it is always creating the appointment from the main calendar and not the shared one. I am having to use "Send Keys" to change it but its not always working.
Can anyone help me with this please!?
I am running the below code to create a calendar appointment but it is always creating the appointment from the main calendar and not the shared one. I am having to use "Send Keys" to change it but its not always working.
Can anyone help me with this please!?
VBA Code:
Option Explicit
'Notes:
'Tab: mail id should be in whether P column or AJ column
Sub Bulk_Invites()
Dim outApp As Object
Dim outNameSpace As Object
Dim outSharedName As Object
Dim outCalendarFolder As Object
Dim outAppointment As Object
Const olAppointmentItem As Long = 1
Dim olApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim SentOnBehalfOfName As Object
Dim i As Byte
Dim cellrng As Range, Rng As Range
Dim attach
Dim strFolderPath As String
Dim strFileName As String
Dim optionalAppointment As Object
Dim sentMailItem As Object
Dim SharedMailboxEmail As String
SharedMailboxEmail = "mysharedmailbox@me.me"
Const olFolderCalendar = 9
'Const olAppointmentItem = 1
Const olImportanceNormal = 1
' Set outCalendarFolder = outCalendarFolder.Folders("mysharedmailbox@me.me ")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Set olApp = outNameSpace.CreateRecipient(SharedMailboxEmail)
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not olApp Is Nothing Then
For i = 1 To 10 'Cells(2, Columns.Count).End(xlToLeft).Column - 1
Set OLNS = olApp.GetNamespace("MAPI")
OLNS.Logon
If LCase(Trim(Cells(3, i + 1))) = "yes" And Len(Trim(Cells(7, i + 1))) = 1 Then
'delay running the next invite for 15 seconds
Application.Wait (Now + TimeValue("0:00:15"))
Set OLAppointment = olApp.CreateItem(olAppointmentItem)
sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
OLAppointment.SentOnBehalfOfName = Cells(25, i).Value
'OLAppointment.MeetingStatus = olMeeting
Set attach = OLAppointment.Attachments
'Set optionalAppointment = olApp.CreateItem(olAppointmentItem)
'Set sentMailItem = olApp.CreateItem(olAppointmentItem)
On Error Resume Next
sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
OLAppointment.SentOnBehalfOfName = Cells(25, i).Value
OLAppointment.Subject = Cells(27, i + 1).Value 'subject
OLAppointment.Start = Cells(19, i + 1).Value + Cells(21, i + 1).Value 'start
OLAppointment.End = Cells(19, i + 1).Value + Cells(23, i + 1).Value 'end
'Mail Body with Greetings
'OLAppointment.Location = "Microsoft Teams Meeting"
OLAppointment.Body = "Hi " & Cells(31, i + 1).Value & vbCr _
& vbCr _
& Cells(33, i + 1).Value & vbCr
OLAppointment.Display
'=============To_Start=================================================================================
For Each cellrng In Sheets(Cells(5, i + 1).Value).Range("B7:B" & Sheets(Cells(5, i + 1).Value).Cells(Rows.Count, 2).End(xlUp).Row)
'Set Rng = Sheets(Cells(5, i + 1).Value).Range("B7:B" & Sheets(Cells(5, i + 1).Value).Cells(Rows.Count, 2).End(xlUp).Row)
'For Each cellrng In Rng
If cellrng = Cells(7, i + 1) Then
If Cells(9, i + 1) = "P" Then
'If cellrng = Cells(7, i + 1) Or cellrng = LCase(Cells(7, i + 1)) Or cellrng = UCase(Cells(7, i + 1)) Then
' If UCase(Trim(Cells(9, i + 1))) = "P" Then
OLAppointment.Recipients.Add cellrng.Offset(0, 14).Value
Else
OLAppointment.Recipients.Add cellrng.Offset(0, 35).Value
End If
OLAppointment.Save
'OLAppointment.Send
End If
Next cellrng
'<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'=============Additional_To_Start=======================================================================
If Cells(15, i + 1) <> "" Then
OLAppointment.Recipients.Add Cells(15, i + 1).Value
End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<Additional_To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'=============To_add_Optional=================================================================================
If Cells(17, i + 1) <> "" Then
Set optionalAppointment = OLAppointment.Recipients.Add(Cells(17, i + 1).Value)
optionalAppointment.Type = 2
End If
'on Behalf
If Cells(25, i + 1) <> "" Then
sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'============Attachment_Start==========================================================================
If Cells(29, i + 1) <> "" Then
strFolderPath = Cells(29, i + 1).Value
strFileName = Dir(strFolderPath)
While Len(strFileName) > 0
attach.Add (strFolderPath & strFileName)
strFileName = Dir
Wend
End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<Attachment_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Application.Wait (Now + TimeValue("0:00:01"))
OLAppointment.Send
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{F10}", True
SendKeys "H", True
SendKeys "i", True
SendKeys "{F10}", True
SendKeys "H", True
SendKeys "TM", True
SendKeys "{F10}", True
Application.Wait (Now + TimeValue("0:00:03"))
'OLAppointment.Display
'SendKeys "{F10}", True
'SendKeys "H", True
'SendKeys "TM", True
'Application.Wait (Now + TimeValue("0:00:05"))
'Application.SendKeys "%s"
'Application.Wait (Now + TimeValue("0:00:05"))
ElseIf Trim(LCase(Cells(3, i + 1))) = "no" Then
'do nothing
Else: 'for Joint Session Name
Set OLAppointment = olApp.CreateItem(olAppointmentItem)
'OLAppointment.MeetingStatus = olMeeting
Set outNameSpace = olApp.GetNamespace("MAPI")
'Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Parent.Folders("mysharedmailbox@me.me ").Folders("mysharedmailbox")
OLAppointment.Display
Set attach = OLAppointment.Attachments
OLAppointment.Location = "Microsoft Teams Meeting"
On Error Resume Next
OLAppointment.Subject = Cells(27, i + 1).Value 'subject
OLAppointment.Start = Cells(19, i + 1).Value + Cells(21, i + 1).Value 'start
OLAppointment.End = Cells(19, i + 1).Value + Cells(23, i + 1).Value 'end
'Mail Body with Greetings
OLAppointment.Body = "Hi " & Cells(31, i + 1).Value & vbCr _
& vbCr _
& Cells(33, i + 1).Value & vbCr
'=============To_Start===============================================================================
Dim listArray() As String, x As Integer
listArray = Split(Cells(7, i + 1), ",")
For x = LBound(listArray) To UBound(listArray)
Set Rng = Sheets(Cells(5, i + 1).Value).Range("B7:B" & Sheets(Cells(5, i + 1).Value).Cells(Rows.Count, 2).End(xlUp).Row)
For Each cellrng In Rng
If cellrng = listArray(x) Or cellrng = LCase(listArray(x)) Or cellrng = UCase(listArray(x)) Then
If Cells(9, i + 1) = "P" Then
OLAppointment.Recipients.Add cellrng.Offset(0, 14).Value
Else
OLAppointment.Recipients.Add cellrng.Offset(0, 35).Value
End If
OLAppointment.Save
End If
Next cellrng
Next x
'<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'=============Additional_To_Start=======================================================================
If Cells(15, i + 1) <> "" Then
OLAppointment.Recipients.Add Cells(15, i + 1).Value
OLAppointment.Save
End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<Additional_To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'=============To_add_Optional=================================================================================
If Cells(17, i + 1) <> "" Then
Set optionalAppointment = OLAppointment.Recipients.Add(Cells(17, i + 1).Value)
optionalAppointment.Type = 2
End If
'on Behalf
If Cells(25, i + 1) <> "" Then
sentMailItem.SentOnBehalfOfName = Cells(25, i + 1).Value
End If
'<<<<<<<<<<<<<<<<<<<<<<<<<<To_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'============Attachment_Start==========
If Cells(29, i + 1) <> "" Then
strFolderPath = Cells(29, i + 1).Value
strFileName = Dir(strFolderPath)
While Len(strFileName) > 0
attach.Add (strFolderPath & strFileName)
strFileName = Dir
Wend
End If
'Application.Wait (Now + TimeValue("0:00:01"))
OLAppointment.Send
Application.Wait (Now + TimeValue("0:00:05"))
'<<<<<<<<<<<<<<<<<<<<<<<<<<Attachment_End>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'MsgBox "Invitation " & i & " have been Completed"
'SendKeys "{F10}", True
'SendKeys "H", True
'SendKeys "TM", True
'Application.Wait (Now + TimeValue("0:00:05"))
'Application.SendKeys "%s"
'Application.Wait (Now + TimeValue("0:00:05"))
SendKeys "{F10}", True
SendKeys "H", True
SendKeys "i", True
Application.Wait (Now + TimeValue("0:00:2"))
SendKeys "{F10}", True
SendKeys "H", True
SendKeys "TM", True
SendKeys "{F10}", True
SendKeys "{8}", True
SendKeys "{3}", True
Application.Wait (Now + TimeValue("0:00:2"))
SendKeys "{F10}", True
SendKeys "H", True
SendKeys "AR", True
SendKeys "T", True
Application.Wait (Now + TimeValue("0:00:10"))
End If
Next i
Application.Wait (Now + TimeValue("0:00:05"))
MsgBox "Invitations have been Completed."
Set OLAppointment = Nothing
Set OLNS = Nothing
Set olApp = Nothing
Set Rng = Nothing
End If
End Sub