Loop Problems

[Debra Farnham]

Hi All

Windows 2K, Access 2K

I am attempting to loop through two recordsets to add appointments to my
Outlook calendar.

In the outer loop, I would like to find all records (the date to be used to
create the calendar entry) where the layoff date matches the date in the
textbox (txtLayoffDate) on my form frmMultipleLayoffs.

Within that loop I want to loop through a second recorset that finds the
names of all employees who meet the criteria in the outer loop.

This what I've got so far, however it doesn't work.

Any help would be greatly appreciated.

TIA

Deba

**********************************

Sub CreateOtherUserAppointment()

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim objAppt As Outlook.AppointmentItem
Dim strMsg As String
Dim strName As String
On Error Resume Next

'Get Unique Dates for item to be added to calendar

Dim db As Database
Dim rst As Recordset
Dim dtmDate As Date
Set db = CurrentDb
Dim rst2 As Recordset
Dim varConcat As Variant
Dim strBody As String
Dim dtmStart As Date
Dim varCon As Variant

Set objApp = CreateObject("Outlook.application")
Set objAppt = objApp.CreateItem(olAppointmentItem)


Set db = CurrentDb

Set rst = db.OpenRecordset("qryUniqueDates", dbOpenSnapshot)

With rst

If .RecordCount <> 0 Then

Do While Not rst.EOF
'NEED TO ONLY LOOP THROUGH RECORDS
'WHERE dtmLayoff = forms!frmMultipleLayoffs!txtLayoffDate
varCon = rst!BenefitsMustBeCancelledBy

Set rst2 = db.OpenRecordset("qryCancelFinal", dbOpenSnapshot)

With rst2
If .RecordCount <> 0 Then

'start concatenating records

Do While Not rst2.EOF
'NEED TO ONLY LOOP THROUGH RECORDS
'WHERE dtmLayoff = forms!frmMultipleLayoffs!txtLayoffDate

'concatenate names of employees found
varConcat = varConcat & rst2!FullName & vbCrLf

.MoveNext
Loop

strBody = Left(varConcat, Len(varConcat) - 2)

End If

End With

Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt
.Start = varCon
.Subject = "Cancel Benefits for individuals listed in
body of this appointment"
.Location = "Open Appointment to View Affected
Individuals"
.Body = strBody
.Categories = "Reminder"
.ReminderSet = True
.ReminderMinutesBeforeStart = 15
.AllDayEvent = True
.Save
End With

Else
MsgBox "Could not find " & Chr(34) & strName & Chr(34),
, _
"User not found"
End If

.MoveNext
Loop
End If
End With


'Exit Outlook
Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing

End Sub

 

[Debra Farnham]

For aynone interested, I am now able to add all day events to my calendar
with reminders for all individuals who have been laid off on a specific
date. The all day event lists the employee names in the body of the all day
appointment whose benefits need to be cancelled.

If someone has a better idea, I'd certainly be open to it.


**********************************
Sub CreateOtherUserAppointment()

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim objAppt As Outlook.AppointmentItem
Dim strMsg As String
Dim strName As String
Dim db As Database
Dim rst As Recordset
Dim dtmDate As Date
Set db = CurrentDb
Dim rst2 As Recordset
Dim varConcat As Variant
Dim strBody As String
Dim dtmStart As Date
Dim varCon As Variant
Dim rstFiltered As Recordset
Dim rst2Filtered As Recordset

On Error Resume Next

' ### name of person whose Calendar you want to use ###
strName = "NameofPerson"

'**Set for testing at home only
Set objApp = CreateObject("Outlook.application")
Set objAppt = objApp.CreateItem(olAppointmentItem)
'**End of Testing at home

Set db = CurrentDb

Set rst = db.OpenRecordset("SELECT qryCancelBenefits.dtmLayOff,
IIf([LessThan2080]='',[MoreThan2080],[LessThan2080]) AS
BenefitsMustBeCancelledBy FROM qryCancelBenefits GROUP BY
qryCancelBenefits.dtmLayOff,
IIf([LessThan2080]='',[MoreThan2080],[LessThan2080])ORDER BY
qryCancelBenefits.dtmLayOff;")
rst.Filter = "qryCancelBenefits.dtmLayOff = " &
Format(Forms!frmMultipleLayoffs!txtLayoffDate, "\#mm\/dd\/yyyy\#")
Set rstFiltered = rst.OpenRecordset

With rstFiltered


If .RecordCount <> 0 Then

Do While Not rstFiltered.EOF

varCon = rstFiltered!BenefitsMustBeCancelledBy


Set rst2 = db.OpenRecordset("qryCancelBenefits2")
rst2.Filter = "BenefitsMustBeCancelledBy = " & Format(varCon,
"\#mm\/dd\/yyyy\#")
Set rst2Filtered = rst2.OpenRecordset

With rst2Filtered

If .RecordCount <> 0 Then

'start concatenating records

Do While Not rst2Filtered.EOF

varConcat = varConcat & rst2Filtered!FullName & vbCrLf

.MoveNext
Loop

strBody = Left(varConcat, Len(varConcat) - 2)


End If
End With

Set objAppt = objApp.CreateItem(olAppointmentItem)
If Not objAppt Is Nothing Then
With objAppt

.Start = varCon
.Subject = "Cancel Benefits for individuals listed in
body of this appointment"
.Location = "Open Appointment to View Affected
Individuals"
.Body = strBody
.Categories = "Reminder"
.ReminderSet = True
.ReminderMinutesBeforeStart = 1440
.AllDayEvent = True
.Save
End With
Else
MsgBox "Could not find " & Chr(34) & strName & Chr(34),
, _
"User not found"
End If

strBody = ""
varConcat = ""
varCon = ""
.MoveNext
Loop
End If
End With


'Exit Outlook
Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing

End Sub
***************************************************