none
Sending Meeting invites with Pictures RRS feed

  • Question

  • Hello

    I have found and am using the below code which perfectly creates and sends meeting invites in outlook 2013. the only issue is that I cant get it to copy the image to the body.

    I think its because the varbody is only lookin at cells not the picture but don't know enough to correct it.

    Any help would be amazing.

    Thanks

    Tom

    ' requires a reference to the Microsoft Outlook x.0 Object Library
    Sub RegisterAppointmentList()
    ' adds a list of appontments to the Calendar in Outlook
        Dim olApp As Outlook.Application
        Dim olAppItem As Outlook.appointmentItem
        Dim r As Long
        Dim myPath As String
        Dim CODE As String
        CODE = Range("I4")
    
        Application.ScreenUpdating = False
        myPath = ActiveWorkbook.Path
    
       ' DeleteTestAppointments    ' deletes previous test appointments
        On Error Resume Next
        Set olApp = GetObject("", "Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            On Error Resume Next
            Set olApp = CreateObject("Outlook.Application")
            On Error GoTo 0
            If olApp Is Nothing Then
                MsgBox "Outlook is not available!"
                Exit Sub
            End If
        End If
    
        r = 10    ' first row with appointment data in the active worksheet
        While Len(Cells(r, 1).Formula) > 0
            Set olAppItem = olApp.CreateItem(olAppointmentItem)    ' creates a new appointment
    
            With olAppItem
                ' set default appointment values
                .Start = Now
                .End = Now
                .Subject = "No subject"
                .Location = ""
                .Body = ""
                .ReminderSet = True
                .MeetingStatus = olMeeting
                
    
                ' read appointment values from the worksheet
                On Error Resume Next
                .Start = Cells(r, 1).Value + Cells(r, 2).Value
                .End = Cells(r, 1).Value + Cells(r, 3).Value
                .Subject = Cells(r, 4).Value
                .Location = Cells(r, 5).Value
                .ReminderSet = Cells(r, 8).Value
                .Importance = Right(Cells(r, 9).Value, 1)
                .RequiredAttendees = Cells(r, 10).Value
                .Categories = CODE   ' add this to be able to delete the testappointments
                On Error GoTo 0
             
               
                .Send    ' saves the new appointment to the default folder
                   
            End With
    
            With olApp
         
                Dim Xl As Excel.Application
                Dim Ws As Excel.Worksheet
                Dim xlRn As Excel.Range
    
                Set Xl = GetObject(, "Excel.Application")
                Set Ws = Xl.Workbooks.Parent.Worksheets(Cells(r, 1).Offset(0, 5).Value)
                Set xlRn = Ws.Range("MailBodyText")
    
    
                Dim varBody As String
                Dim objdata As DataObject
                Dim DataObject As Object
                Set objdata = New DataObject
    
                Application.GoTo Reference:=xlRn
                Selection.Copy
                objdata.GetFromClipboard
                varBody = objdata.GetText
    
                With olAppItem
                    .Body = varBody  '& vbCrLf & vbCrLf
                End With
            End With
    
            olAppItem.Close olSave
            r = r + 1
            Sheets("scheduleapp").Activate
        Wend
        Set olAppItem = Nothing
        Set olApp = Nothing
        
        Application.ScreenUpdating = True
        MsgBox "invites Sent"
    End Sub

    Tuesday, March 21, 2017 7:17 PM

Answers