1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
| Sub NewMeet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Variable declarations
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim mysub, myStart, myEnd
Dim olNs As Outlook.Namespace
Dim oPattern As RecurrencePattern
Dim CalFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Set olApp = GetObject("", "Outlook.Application")
Set olApp = CreateObject("Outlook.Application")
ThisWorkbook.Sheets(1).Activate
Line = 3
'Scanning line by line to createnew meetings
Do While ThisWorkbook.Sheets(1).Cells(Line, 1) <> ""
'If meeting already created, bypass
If ThisWorkbook.Sheets(1).Cells(Line, 12) = "Yes" Then
GoTo Bypass
End If
'Errorhandling on meeting dates and time
If ThisWorkbook.Sheets(1).Cells(Line, 4) = "" Or ThisWorkbook.Sheets(1).Cells(Line, 5) = "" Or ThisWorkbook.Sheets(1).Cells(Line, 6) = "" Then
MsgBox ("Line " & Line & " is missing timing data")
GoTo Bypass
End If
MSubj = ThisWorkbook.Sheets(1).Cells(Line, 1) 'Subject
MLoc = ThisWorkbook.Sheets(1).Cells(Line, 2) 'Location
MBod = ThisWorkbook.Sheets(1).Cells(Line, 9) 'Body
MList = ThisWorkbook.Sheets(1).Cells(Line, 3) 'Email list
AttachPath = ThisWorkbook.Sheets(1).Cells(Line, 10) 'Attachementpath
MRecu = ThisWorkbook.Sheets(1).Cells(Line, 7) 'Recurrence: evey
MPerRecu = ThisWorkbook.Sheets(1).Cells(Line, 8) 'Recurrence: period
MStart = DateValue(ThisWorkbook.Sheets(1).Cells(Line, 4).Value) + ThisWorkbook.Sheets(1).Cells(Line, 5).Value 'Start Date & Time
MEnd = DateValue(ThisWorkbook.Sheets(1).Cells(Line, 4).Value) + ThisWorkbook.Sheets(1).Cells(Line, 6).Value 'End Date& time
If ThisWorkbook.Sheets(1).Cells(Line, 11) <> "" Then 'Case ofSubfolder
SubCal = ThisWorkbook.Sheets(1).Cells(Line, 11)
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
Set subFolder = CalFolder.Folders(SubCal)
Set olAppItem = subFolder.Items.Add(olAppointmentItem)
Else 'If empty, default folder
Set olAppItem = olApp.CreateItem(olAppointmentItem)
End If
'Creation of meeting with or without attachement
If AttachPath <> "" Then
With olAppItem
.Location = MLoc
.Body = MBod
.RequiredAttendees = MList
.Start = MStart
.End = MEnd
.Subject = MSubj
.Attachments.Add (AttachPath)
.MeetingStatus = olMeeting
.Location = MLoc
.Body = MBod
End With
Else
With olAppItem
.Location = MLoc
.Body = MBod
.RequiredAttendees = MList
.Start = MStart
.End = MEnd
.Subject = MSubj
.MeetingStatus = olMeeting
.Location = MLoc
.Body = MBod
End With
End If
'Recurrent meeting setup or not
If MRecu = "" And MPerRecu = "" Then
GoTo NoRec 'No recurrence
Else
'Error handling on recurrence
If MRecu = "" Or MPerRecu = "" Then
MsgBox ("Recurrence Column G or H not filled completly")
Set oPattern = Nothing
GoTo Bypass
End If
If IsNumeric(MRecu) = False Then
MsgBox ("Recurrence Column G needs to be numerical")
Set oPattern = Nothing
GoTo Bypass
End If
If MPerRecu <> "D" And MPerRecu <> "M" And MPerRecu <> "W" Then
MsgBox ("Recurrence Column H needs to be D, W or M")
Set oPattern = Nothing
GoTo Bypass
End If
'Recurrence: every x period
Set oPattern = olAppItem.GetRecurrencePattern
If MPerRecu = "D" Then
oPattern.RecurrenceType = olRecursDaily
oPattern.Interval = MRecu
Set oPattern = Nothing
End If
If MPerRecu = "W" Then
oPattern.RecurrenceType = olRecursWeekly
oPattern.Interval = MRecu
Set oPattern = Nothing
End If
If MPerRecu = "M" Then
oPattern.RecurrenceType = olRecursMonthly
oPattern.Interval = MRecu
Set oPattern = Nothing
End If
End If
NoRec:
olAppItem.Save
olAppItem.Send
ThisWorkbook.Sheets(1).Cells(Line, 12) = "Yes"
Bypass:
If ThisWorkbook.Sheets(1).Cells(Line, 11) <> "" Then
Set subFolder = Nothing
End If
Set olAppItem = Nothing
Set olApp = Nothing
Line = Line + 1
Loop
End Sub |
Partager