adding outlook appointments via vb

R

Rengade

Hi all

I am trying to add a number of appoitments into outlook via access table and
using the below code

----------------
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("tblApptExport")
MyRS.MoveFirst

Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)

Do Until MyRS.EOF

' Save record first to be sure required fields are filled
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
With outappt
.Subject = Me!ApptSubject
.Start = Me!ApptDate & " " & Me!ApptStartTime
.End = Me!ApptDate & " " & Me!ApptEndTime
.location = Me!ApptLocation
.ReminderSet = False
.Save
MyRS.MoveNext
End With
Loop
MsgBox "Appointments Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub

----------------------------

The loop doesn't seem to work as I only get the first record exported into
outlook

Please help
 
D

Douglas J. Steele

Your use of Me!ApptSubject, Me!ApptDate, Me!ApptStartTime and so on means
that you're getting values from the current row on the form, not from the
recordset.

Assuming that the data's supposed to be coming from the recordset, you need
to use

Do Until MyRS.EOF

' Save record first to be sure required fields are filled
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
With outappt
.Subject = MyRS!ApptSubject
.Start = MyRS!ApptDate & " " & MyRS!ApptStartTime
.End = MyRS!ApptDate & " " & MyRS!ApptEndTime
.location = MyRS!ApptLocation
.ReminderSet = False
.Save
End With
MyRS.MoveNext
Loop

Incidentally, you'd be better off storing the appointment start and end
times as timestamps (both the date and the time), rather than separate
fields. If you want only the date portion, use the DateValue function. If
you want only the time portion, use the TimeValue function.
 
T

Tom van Stiphout

Hi all

I am trying to add a number of appoitments into outlook via access table and
using the below code

----------------
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("tblApptExport")
MyRS.MoveFirst

Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)

Do Until MyRS.EOF

' Save record first to be sure required fields are filled
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
With outappt
.Subject = Me!ApptSubject
.Start = Me!ApptDate & " " & Me!ApptStartTime
.End = Me!ApptDate & " " & Me!ApptEndTime
.location = Me!ApptLocation
.ReminderSet = False
.Save
MyRS.MoveNext
End With
Loop
MsgBox "Appointments Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub

----------------------------

The loop doesn't seem to work as I only get the first record exported into
outlook

Please help
Click to expand...
 
T

Tom van Stiphout

On Wed, 16 Jul 2008 05:35:18 -0700, Rengade

I think mostly a matter of putting things in the right location,
especially creating a new apptitem within the loop:

DoCmd.RunCommand acCmdSaveRecord
MyRS.MoveFirst
Set outobj = CreateObject("outlook.application")
Do Until MyRS.EOF
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt

-Tom.
 
R

Rengade

Many thanks,

I have changed the code as suggested to the below, I am now getting the
error message "Error 3265 Item not found in this collection"
===========================================
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("tblApptExport")
DoCmd.RunCommand acCmdSaveRecord
MyRS.MoveFirst
Set outobj = CreateObject("outlook.application")
Do Until MyRS.EOF
DoCmd.RunCommand acCmdSaveRecord
With outappt
.Subject = MyRS!ApptSubject
.Start = MyRS!ApptDate & " " & MyRS!ApptStartTime
.End = MyRS!ApptDate & " " & MyRS!ApptEndTime
.location = MyRS!ApptLocation
.ReminderSet = False
.Save
End With
MyRS.MoveNext
Loop

MsgBox "Appointments Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
===============================
 
R

Rengade

Sorry that was just me being stupid, have now changed the code to below
getting error message: "error 91 - Object variable or With block variable not
set"

Any ideas???


==============================
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("tblApptExport")
DoCmd.RunCommand acCmdSaveRecord
MyRS.MoveFirst
Set outobj = CreateObject("outlook.application")
Do Until MyRS.EOF
DoCmd.RunCommand acCmdSaveRecord
With outappt
.Subject = MyRS!Course
.Start = MyRS!StdCourseDate & " " & MyRS!StdCourseStartTime
.End = MyRS!StdCourseDate & " " & MyRS!FinishTime
.location = MyRS!StdCourseLocation
.ReminderSet = False
.Save
End With
MyRS.MoveNext
Loop

MsgBox "Appointments Added!"
Exit Sub
===============================
 
R

Rengade

the below code now works.....but it only seems to add the last record in the
table and not the other 3 records before it...... any idea's please?????

=================================
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("tblApptExport")
DoCmd.RunCommand acCmdSaveRecord
MyRS.MoveFirst
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)

Do Until MyRS.EOF
DoCmd.RunCommand acCmdSaveRecord
With outappt
.Subject = MyRS!Course
.Start = MyRS!StdCourseDate & " " & MyRS!StdCourseStartTime
.End = MyRS!StdCourseDate & " " & MyRS!FinishTime
.location = MyRS!StdCourseLocation
.ReminderSet = False
.Save
End With
MyRS.MoveNext
Loop
=========================
 
D

Douglas J. Steele

As was pointed out yesterday (not by me), you need to create the new
appointment item inside the loop:

Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("tblApptExport")
MyRS.MoveFirst
Set outobj = CreateObject("outlook.application")

Do Until MyRS.EOF
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.Subject = MyRS!Course
.Start = MyRS!StdCourseDate & " " & MyRS!StdCourseStartTime
.End = MyRS!StdCourseDate & " " & MyRS!FinishTime
.location = MyRS!StdCourseLocation
.ReminderSet = False
.Save
End With
Set outappt = Nothing
MyRS.MoveNext
Loop

Note that I removed the "DoCmd.RunCommand acCmdSaveRecord": I don't believe
they're necessary (especially not inside the loop)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Using Automation to Add Appointments to Microsoft Outlook 1
MS Access setting outlook reminders from a DAO recordset 0
Using Access to enter Appointments 1
VBA code to insert appointment in Outlook 5
Mail Merge Email 2
Outlook 2002 and 2003 4
Letter Templates in Access 1
Add Contact Link for Appointment Item using Links Collection 3

Top