Hi,
I think this is what you need. Sorry I owe you the bold text in the body
.
Run the macro called :GenerateMeetingRequests
Main Code:
Sub GenerateMeetingRequests()
Dim outApp As Object
Dim lRow As Long
Dim i As Long
Call TurnExtrasOff
Set outApp = CreateObject("Outlook.Application")
lRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through all the rows. Note we start in row 2.
For i = 2 To lRow
Call CreateMeetingRequest(outApp, i)
Next i
Call TurnExtrasOn
' Clean up
Set outApp = Nothing
End Sub
Sub to generate the meeting:
Sub CreateMeetingRequest(ByRef outApp As Object, ByVal lRowNumber As Long)
Dim oMeeting As Object
Dim arrAttachements As Variant
Dim i As Long
Set oMeeting = outApp.CreateItem(1) ' olAppointmentItem
With oMeeting
.MeetingStatus = 1 'olMeeting
.Recipients.Add Cells(lRowNumber, 1).Value
' If the receipeient is not in your address outlook will not allow to send it.
If Not .Recipients.ResolveAll Then GoTo Exit_Handler
.Subject = Cells(lRowNumber, 4).Value
.Location = Cells(lRowNumber, 5).Value
.Start = Cells(lRowNumber, 6).Value
.End = Cells(lRowNumber, 7).Value
.Body = Cells(lRowNumber, 8).Value
' Add all the attachements if any
If Not Range("I2").Value = vbNullString Then
arrAttachements = GetAttachmentsPaths(Cells(lRowNumber, 9).Value)
' Loop throught tha array to add the attachements.
For i = LBound(arrAttachements) To UBound(arrAttachements)
If DoesFileExist(arrAttachements(i)) Then
.Attachments.Add arrAttachements(i)
End If
Next i
End If
' Uncomment send and comment display when you are happy
' with the results.
.Display
.Send
End With
Exit_Handler:
' Clean up
Set oMeeting = Nothing
End Sub
Other function and helper subs:
Function GetAttachmentsPaths(ByVal strInfo As String) As Variant
Dim ret As Variant
If Not strInfo = vbNullString Then
If InStr(1, strInfo, ";") <> 0 Then
' Replace the "; " with a more reliable "|" Delimiter
strInfo = Replace(strInfo, "; ", "|")
strInfo = Replace(strInfo, ";", "|")
' Add the values to an array reparting by "|"
ret = Split(strInfo, "|")
Else
ret = Array(strInfo)
End If
End If
' Return the value
GetAttachmentsPaths = ret
End Function
Function DoesFileExist(ByVal strFullPath As String) As Boolean
Dim ret As Boolean
If Not Dir$(strFullPath) = vbNullString Then
ret = True
Else
ret = False
End If
' Return the value.
DoesFileExist = ret
End Function
Sub TurnExtrasOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Sub TurnExtrasOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I hope this helps
excel-outlook macro.xlsm
Thanks
Bookmarks