Creating Several Appointment at Once in Outlook Using Access

[Accel45]

I am using the following code Microsoft Sample code to add appointments to Outlook from Access. This code sends one appointment at a time. I have attempted to modify the code below to send several appointments at once based on the records I select from a listbox. So far I no matter how many I select the only record sent is the one with the lowest ItemID number (autonumber) regardless of whether it was select or not.

Any help in modifying this code to work with records selected in a listbox would be appreciated.

(Code I have been attempting to incorporate)
Dim varSelected As Variant
Dim strSQL As String
For Each varSelected In Me!List30.ItemsSelected
strSQL = strSQL & Me!List30.ItemData(varSelected) & ","
Next varSelected
If strSQL <> "" Then
strSQL = "[ItemID] IN (" & Left(strSQL, Len(strSQL) - 1) & ")"


(Microsoft Sample Code)
Private Sub AddAppt_Click()
On Error GoTo AddAppt_Err
' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.Start = Me!ApptDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!Appt
If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNotes
If Not IsNull(Me!ApptLocation) Then .Location = _
Me!ApptLocation
If Me!ApptReminder Then
.ReminderMinutesBeforeStart = Me!ReminderMinutes
.ReminderSet = True
End If
.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub