Hi
I have adapted code by Helen Feddema to export calendar items to outlook
using early binding. It works perfectly but the database is multi-user & not
all users have Outlook - Novell Groupwise is used instead by these users.
So the problems are as follows:
1. Users without Outlook installed do not have the Outlook Reference library
file msoutl.olb so they get an error at start up. Will this be fixed if I
just copy this file to their computers along with the database front-end
....or do I need to register this on this machine also?
2. If the above suggestions won't work, how can I convert the code to use
late binding - the main part of the code is listed below - apologies fir its
length
3. Does anyone know how to export the data into a Groupwise calendar for
users who use that instead of Outlook? There are various Groupwise reference
library files available in Access but I don't know where to start...
======================================
Code using early binding:
Option Compare Database
Option Explicit
Dim dbs As Database
Dim rst As Recordset
Dim appOutlook As New Outlook.Application
Dim itm As Outlook.AppointmentItem
Dim rcp As Outlook.Recipient
Dim strContactName As String
Dim strFolder As String
Dim nms As Outlook.NameSpace
Dim flds As Outlook.Folders
Dim blnFound As Boolean
Dim fld As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim appt As Outlook.AppointmentItem
Dim lngCount As Integer
Dim strTitle As String
Dim strDateFilter As String
-------------------------------------------------------------------------------------------------
Public Sub CheckOutlook()
'check if Outlook is installed (v2002 to 2010)
If FileOrDirExists("C:\Program Files\Microsoft Office\OFFICE11\OUTLOOK.EXE")
= False Then 'Outlook 2003
If FileOrDirExists("C:\Program Files\Microsoft
Office\OFFICE12\OUTLOOK.EXE") = False Then 'Outlook 2007
If FileOrDirExists("C:\Program Files\Microsoft
Office\OFFICE14\OUTLOOK.EXE") = False Then 'Outlook 2010
If FileOrDirExists("C:\Program Files\Microsoft
Office\OFFICE10\OUTLOOK.EXE") = False Then 'Outlook 2002
MsgBox "You cannot do the export as Outlook is not
installed" & _
" on this computer ", vbCritical, "Export to Outlook"
Exit Sub
End If
End If
End If
End If
End Sub
--------------------------------------------------------------------------------------------------
Public Sub ExportTimetableCalendar()
On Error GoTo ErrorHandler
'Check if Outlook is installed on the user's computer
CheckOutlook
'Explain routine to user
strMsg = "This routine will export timetable & calendar items to Outlook
" & vbNewLine & vbNewLine & _
"A new folder RMPCalendar will be created in Outlook if it does not
already exist " & vbNewLine & vbNewLine & _
"NOTE: All existing items in thnis folder will be replaced to avoid
duplication " & vbNewLine & vbNewLine & _
"Are you sure you wish to run this routine?"
strTitle = "Export timetable & calendar?"
If MsgBox(strMsg, vbYesNo + vbDefaultButton2 + vbExclamation, strTitle)
= vbNo Then Exit Sub
'check type of export required - rest of academic year (default) or whole
academic year
strMsg = "Choose which events to export " & vbNewLine & _
"===================" & vbNewLine & vbNewLine & _
"Click YES to export future events for the rest of the academic year
only (RECOMMENDED) " & vbNewLine & _
"Click NO to export ALL events for the whole academic year " &
vbNewLine & _
"Click CANCEL to exit this routine"
strTitle = "Choose export events required"
Select Case MsgBox(strMsg, vbYesNoCancel + vbExclamation, strTitle)
Case vbYes
strDateFilter = " AND SchCalendar.DayDate >=Date()" 'future
events only (default)
Case vbNo
strDateFilter = "" 'all events for current academic year
Case vbCancel
Exit Sub 'abort routine
End Select
'Define Outlook folder & set up items
strFolder = "RMPCalendar"
'strFolder = "Calendar"
Set nms = appOutlook.GetNamespace("MAPI")
Set flds = nms.Folders("Personal Folders").Folders
Set nms = appOutlook.GetNamespace("MAPI")
'Check for existence of RMPCalendar folder and create it if not found
blnFound = False
'Open Outlook
Set appOutlook = GetObject(, "Outlook.Application")
'Set appOutlook = CreateObject("Outlook.Application")
For Each fld In flds
If fld.Name = strFolder Then
blnFound = True 'RMPCalendar folder exists
fld.Delete 'so delete it so it will be recreated
blnFound = False
End If
Next fld
If blnFound = True Then
Set fld = flds(strFolder)
ElseIf blnFound = False Then
Set fld = flds.Add(strFolder, olFolderCalendar)
End If
Set itms = fld.Items
'Get reference to data table
Set dbs = CurrentDb
'run the exports
DoCmd.Hourglass True
ExportTeacherTimetable
DoCmd.Hourglass False
MsgBox "Timetable & Calendar exported successfully. ", vbInformation
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If err.Number = 429 Then 'Outlook is not running; open Outlook with
CreateObject
Set appOutlook = CreateObject("Outlook.Application")
Resume Next
End If
If err.Number = -2147467259 Then
MsgBox "You need to have a Personal Folders (PST) file in Outlook
for the export to work successfully. " & vbNewLine & _
"Please create this file in Outlook before you run this routine
again ", vbCritical, "Export failed!"
Else
MsgBox "Error No: " & err.Number & "; Description: " & err.Description
End If
Resume ErrorHandlerExit
End Sub
---------------------------------------------------------------------------------------------
Public Sub ExportTeacherTimetable()
On Error GoTo ErrorHandler
'Create recordset for teacher timetable based on event date choice
(strDateFilter)
strSQL1 = "SELECT qryTimetable.Lesson, [DayDate] & ' ' & [StartTime] AS
DateStartTime," & _
" [DayDate] & ' ' & [EndTime] AS DateEndTime, qryTimetable.ClassID,
qryTimetable.TeacherID, qryTimetable.RoomID" & _
" FROM (qryTimetable INNER JOIN SchDay ON qryTimetable.Period =
SchDay.LessonID)" & _
" INNER JOIN SchCalendar ON (qryTimetable.Day = SchCalendar.SessionDay)"
& _
" AND (qryTimetable.WeekNumber = SchCalendar.WeekNumber)" & _
" WHERE ((qryTimetable.TeacherID = GetLoggedOnTeacher()) " &
strDateFilter & ")" & _
" ORDER BY SchCalendar.DayDate, qryTimetable.LessonID;"
'Debug.Print strSQL1
Set rst = dbs.OpenRecordset(strSQL1)
rst.MoveLast
rst.MoveFirst
lngCount = rst.RecordCount
'Debug.Print lngCount
'Loop through table, exporting each record to Outlook
Do Until rst.EOF
'Create an appointment item
Set appt = itms.Add("IPM.Appointment")
With appt
.Subject = Nz(rst![ClassID])
'.Categories = Nz(rst![Category])
.Start = Nz(rst![DateStartTime])
.End = Nz(rst![DateEndTime])
.AllDayEvent = False
.Location = Nz(rst![RoomID])
.ReminderMinutesBeforeStart = 20
.ReminderOverrideDefault = True
.ReminderPlaySound = True
.ReminderSet = True
.ReminderSoundFile = "C:\Windows\Media\notify.wav"
.Close (olSave)
End With
rst.MoveNext
Loop
rst.Close
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & err.Number & "; Description: " & err.Description
Resume ErrorHandlerExit
End Sub
|
Similar Threads
