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