Set an appointment in Outlook using Excel VBA

Question

I have an Excel sheet to input a person's data (name, email address, cell phone number, service provide, date of appointment, appointment type, appointment time).

When a button is pushed an email in Outlook should be drafted as well as an appointment to be sent to the member.

How can I pull the member's email address or appointment date and time from the Excel sheet into the Outlook appointment?

Sub Button2test_Click()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, 
    xlTextValues)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
          vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = Range("$F$2")
        .CC = Range("$B$2")
        .BCC = ""
        .Subject = "Upcoming Scheduled Appointment"
        .HTMLBody = Range("$K$2")
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        .Display
    End With
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = 
        Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, 
    xlTextValues)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
          vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olAppointmentItem)
    OutMail.MeetingStatus = olMeeting
    
    On Error Resume Next
    With OutMail
        .To = Range("$F$2")
        .Subject = Range("I2")
        .Location = Range("I2")
        .Importance = True
        .Start = Range("J2") & Format(Date + "H2")
        .End = Range("J2") & Format(Time + 0)
        .ReminderMinutesBeforeStart = 30
        .Body = Range("K2")
        .Display
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Answer 1

I have made update to the meeting part as there is no To field in meeting its required attendees and optional attendees.

Sub Button2test_Click()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
     On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = 
    Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, 
    xlTextValues)
    On Error GoTo 0

    If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
    End If

    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
    .To = Range("$F$2")
    .CC = Range("$B$2")
    .BCC = ""
    .Subject = "Upcoming Scheduled Appointment"
    .HTMLBody = Range("$K$2")
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .Display
    End With
    On Error GoTo 0

    With Application
    .EnableEvents = True
    .ScreenUpdating = True
     End With

     Set OutMail = Nothing
     Set OutApp = Nothing


    Set rng = Nothing
    On Error Resume Next
    ' Only send the visible cells in the selection.
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, 
     xlTextValues)
    On Error GoTo 0

    If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
    End If

    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olAppointmentItem)
    OutMail.MeetingStatus = olMeeting

    On Error Resume Next
    With OutMail
    .requiredattendees  = Range("$F$2")
    .Subject = Range("I2")
    .Location = Range("I2")
    .Start = Range("J2") & Format(Date + "H2")'Format should be DD/MM/YYY(or as per your local settings) HH:MM:SS AM/PM(example 13/12/2020 08:30:00 PM)
    .End = Range("J2") & Format(Time + 0)'Format should be DD/MM/YYY(or as per your local settings) HH:MM:SS AM/PM(example 13/12/2020 08:30:00 PM)
    .ReminderMinutesBeforeStart = 30
    .Body = Range("K2")
    .Display
    End With


    With Application
    .EnableEvents = True
    .ScreenUpdating = True
    End With

   Set OutMail = Nothing
   Set OutApp = Nothing
End Sub

Answer 2

It is very difficult to guess what your code is trying to do. Here are a few points to get you started.

Used like this On Error Resume Next means “don’t bother telling me about any errors because I like mysterious failures. For the moment, just delete all On Error statements.

Some of your code addresses explicit cells: D4:D12, F2, B2, K2 and I2. Other code addresses visible cells within a Selection. Mixing two techniques for addressing cells makes no sense to me.

You have Set rng = Nothing down to Set OutApp = Nothing then you have the same block of code again but with additions. You need to decide which block of code you want.

What do you think this statement does:

Set rng = 
Sheets("Sheet1").RangeToHtml("D4:D12").SpecialCells(xlCellTypeVisible, 
xlTextValues)

You cannot spread a statement over several lines unless there is an underscore at the end of the lines to be continued. Even if it was syntactically correct, I do not see how this statement is relevant to the rest of the macro.

Is cell K2 really an Html body? I suspect it is a text body.

I retired some years ago so my memory of appointments has faded. My recollection is we sent invitations and the receiver turned them into appointments by accepting them. Even if these are regular team meetings, or similar, you need the attendees to accept or reject the invitations because you want to know who will be coming.