Small problem adding Outlook task in Access 2010

[Balder]

Hi

In my Human resources system the user can add a task in Outlook 2010.

The code is :

Function fncAddOutlookTask()
Dim OutlookApp As Object
Dim OutlookTask As Outlook.TaskItem



Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookTask = OutlookApp.CreateItem(olTaskItem)

With OutlookTask
.Subject = Me.Subject & " " & "IDnr" & Me.Idnr
.Body = Me.Body & " "
.ReminderSet = True
.ReminderTime = DateAdd("n", 2, Me.Reminder1 & " " & Me.Reminder2)
.DueDate = DateAdd("n", 5, Me.Due & " " & Me.Due2)
.ReminderPlaySound = True
.ReminderSoundFile = "C:\Windows\Media\ringout.wav"
.Save
End With


End Function

When outlook is open everything works just fine. When Outlook is closed
it doesn't open Outlook but produces the following message:

The reminder for "whatever" will not appear because the item
is in a folder that doesn't support reminders. Is this ok? Yes/ No

On YES the reminder is added, but on NO i get :
Run time error
Cannot save this item.

It is just a bit annoying, i could live with it but any advice about how to fix this would be appreciated.

Balder
Norway

 

[ted.martin]

One way round the problem would be to ensure Outlook is running.

Dev has the following code on his site but just call it at the beginning of your code as below:

If (fIsAppRunning("Outlook")) = False Then
MsgBox "Outlook is not running!" & vbLf & vbLf & "eMail cannot be prepared.", vbExclamation, "Need to Start Outlook and Try again"

' The next line will start Outlook if you like!
'Call Shell("c:\Program Files\Microsoft Office\Office12\outlook.exe", 1)
docmd.Quit
Exit Function
Else
'MsgBox "Outlook is running"
End If



'This code was originally written by Dev Ashish.
'It is not to be altered or distributed except as part of an application.
'You are free to use it in any application provided the copyright notice is left unchanged.
'
'Code Courtesy of Dev Ashish
'
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10

Private Declare Function apiFindWindow Lib "user32" Alias _
"FindWindowA" (ByVal strClass As String, _
ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
"SendMessageA" (ByVal Hwnd As Long, ByVal Msg As Long, ByVal _
wParam As Long, lParam As Long) As Long

Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
"SetForegroundWindow" (ByVal Hwnd As Long) As Long

Private Declare Function apiShowWindow Lib "user32" Alias _
"ShowWindow" (ByVal Hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function apiIsIconic Lib "user32" Alias _
"IsIconic" (ByVal Hwnd As Long) As Long

Function fIsAppRunning(ByVal strAppName As String, Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
Case "excel": strClassName = "XLMain"
Case "word": strClassName = "OpusApp"
Case "access": strClassName = "OMain"
Case "powerpoint95": strClassName = "PP7FrameClass"
Case "powerpoint97": strClassName = "PP97FrameClass"
Case "notepad": strClassName = "NOTEPAD"
Case "paintbrush": strClassName = "pbParent"
Case "wordpad": strClassName = "WordPadClass"

Case "Outlook": strClassName = "rctrl_renwnd32"

Case Else: strClassName = vbNullString
End Select

If strClassName = "" Then
lngH = apiFindWindow(vbNullString, strAppName)
Else
lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
apiSendMessage lngH, WM_USER + 18, 0, 0
lngX = apiIsIconic(lngH)
If lngX <> 0 Then
lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
End If
If fActivate Then
lngTmp = apiSetForegroundWindow(lngH)
End If
fIsAppRunning = True
End If
fIsAppRunning_Exit:
Exit Function
fIsAppRunning_Err:
fIsAppRunning = False
Resume fIsAppRunning_Exit
End Function

 

[Balder]

Hi

Thanks
Will try a soon as i get back from work tonight.

Balder
Norway