Hi All, this is my first time posting to this site, but I'm hoping you can help me. I've been unsuccessful in trying to modify this macro so that the user-defined fields I've built in a custom outlook form will carry over into recurring meeting makers. The code performs very well when it comes to carrying over the standard form values, and it also converts the standard form to my template, but unfortunately, it does not carry over the values in my custom form fields. I've tried multiple iterations, with no luck. Any help would be much appreciated! I've bolded the portion where my code is erroring out. Thank you!
Sub ConvertRecurring() Dim CalFolder As Outlook.MAPIFolder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter, strSubject As String
Dim iNumRestricted As Integer
Dim itm, newAppt As Object
Dim tStart, tEnd As Date
Dim recAppt As Object
Dim objProp As Outlook.UserProperty
' Use the selected calendar folder
Set CalFolder = Application.ActiveExplorer.CurrentFolder
Set recAppt = Application.ActiveExplorer.Selection.Item(1)
' Get all of the appointments in the folder
Set CalItems = CalFolder.Items
' Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
' Include the recurrences from the selected date forward
CalItems.IncludeRecurrences = True
' Pick up the Start Date of the selected appointment occurrence
' Use a List view to get all occurrences
tStart = Format(recAppt.Start, "Short Date")
' macro limits all appt to 360 days from now
' so you can end a series early
tEnd = Format(Now + 360, "Short Date")
' Pick up the selected appointment's subject
strSubject = recAppt.Subject
'create the Restrict filter
sFilter = "[Start] >= '" & tStart & "'" & " And [End] < '" & tEnd & "' And [IsRecurring] = True And [Subject] = " & Chr(34) & strSubject & Chr(34)
' Apply the filter to the collection
Set ResItems = CalItems.Restrict(sFilter)
iNumRestricted = 0
'Loop through the items in the collection.
For Each itm In ResItems
iNumRestricted = iNumRestricted + 1
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
newAppt.MessageClass = "IPM.Appointment.PMAppointment-v4"
With newAppt
.Start = itm.Start
.End = itm.End
.Subject = itm.Subject
.Body = itm.Body
.Location = itm.Location
.Categories = itm.Categories
.ReminderSet = False
.Save
'calling user-defined fields from form
Set objProp = newAppt.UserProperties.Add("ProjectName", olText, True)
objProp.Value = itm.UserProperties("ProjectName").Value
.Save
End With
' Copies attachments to each appointment.
If itm.Attachments.Count > 0 Then
CopyAttachments itm, newAppt
End If
newAppt.Save
Next
' Display the actual number of appointments created
MsgBox (iNumRestricted & " appointments were created"), vbOKOnly, "Convert Recurring Appointments"
Set itm = Nothing
Set newAppt = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
Set objProp = Nothing
End Sub
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub