Good'day Everyone,
I have Frankensteined (ie there will be a lot of redundant code that I only deleted partially) the following code from various sources online and it is doing exactly as I want but missing the crucial last action. I altered the values of this VBA to create a meeting request in Outlook based on Values on a worksheet. There is also a body text that must go onto the Meeting Request Message body and the value is Sheets("Email").Range("B1:M48"). With my fairly limited VBA knowledge I was able to copy the values I want from the correct work sheet, but I was not able to find the VBA that allows me to paste clipboard onto the Outlook Meeting Request window that opens at the end of the script.
This could be a 1 liner fix for anyone with the answer but I have spent the last 3 days googling to no avail :yikes: Your assistance is greatly appreciated!
Option Explicit
Public Sub CreateOutlookApptTZ()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Appointment").Visible = True
Sheets("Appointment").Select
' On Error GoTo Err_Execute
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim arrCal As String
Dim tzStart As TimeZone, tzEnd As TimeZone
Dim i As Long
On Error Resume Next
Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
Set olAppt = CalFolder.Items.Add(olAppointmentItem)
With olAppt
'Define calendar item properties
.Start = Cells(i, 6) + Cells(i, 7) '+ TimeValue("9:00:00")
.End = Cells(i, 8) + Cells(i, 9) '+TimeValue("10:00:00")
.Subject = Cells(i, 2)
.Location = Cells(i, 3)
'I can not seem to use the body function as Sheets("Email").Range("B1:M48").Select
'.Body = Sheets("Email").Range("B1:M48").Select
.BusyStatus = olBusy
.RequiredAttendees = Cells(i, 12).Value
.ReminderMinutesBeforeStart = Cells(i, 10)
.ReminderSet = True
.Categories = Cells(i, 5)
.Display
End With
Sheets("Appointment").Visible = False
'copies the data I want from sheet email
Sheets("Email").Range("B1:M48").Select
Selection.Copy
Application.DisplayAlerts = True
Application.ScreenUpdating = True
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
If False Then
olAppt.Close olSave
olAppt.Send
Else
olAppt.Save
olAppt.Display
End If
'Insert Last function Required to paste clipboard into Outlook Meeting request window in 'Message Body' that is open!
End Sub