Urgent - Detect Crash + Kill Program

[Stevie]

I have some code which loops through all emails in a specified (outlook) folder, and copys all the attachments to my hard drive which are word documents.

Trouble is if Outlook goes down whilst this is happening my program just freezes as Outlook is Not Responding.

How can I detect if Outlook is Not Responding, and Kill it if it isn't responding?

(also is there any way of simulating Outlook going down, to make testing this better than just waiting for it to go down? )

[Nucleus]

If your program just freezes, I don't see how. Contrarily, if an error is thrown when Outlook keels over then you might be in luck.

Which is it?

[Stevie]

My program doesn't actually freeze, it's just waiting to be able to read the next mail item, which it won't be able to do as Outlook is down.

If I put a DoEvents in there, just before I read a mail item and somehow check if Outlook is ok I can carry on, else if it's down I can exit the loop and kill Outlook.

Just don 't know how to do it

[Nucleus]

You need to add code to restart outlook, but the code to close if the app is hung should work although untested, so you might have to fiddle. Also it assumes only one version of outlook at any one time.

Option Explicit
 
 
 
 
Private Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String)
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Const WM_NULL = &H0
Private Const SMTO_ABORTIFHUNG = &H2
 
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const PROCESS_ALL_ACCESS = &H1F0FFF
 
Private Declare Function TerminateProcess& Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long)
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
 
Sub RestartOutlookIfHung()
Dim lhwnd&, pid&, hp&
 
lhwnd = FindWindow("rctrl_renwnd32", vbNullString)
If (SendMessageTimeout(lhwnd, WM_NULL, 0, 0, SMTO_ABORTIFHUNG, 10, 0) = 0) Then
    GetWindowThreadProcessId lhwnd, pid
    hp = OpenProcess(PROCESS_ALL_ACCESS, 0&, pid)
    TerminateProcess hp&, 0&
    CloseHandle hp
End If
 
'You add code to restart outlook here
End Sub

[Stevie]

Cheers

I'll try it out this afternoon.

[Stevie]

Just got round to trying this, this morning.

Can you tell me how the code in red should be dim'd?

Dim lhwnd&, pid&, hp&

  lhwnd = FindWindow("rctrl_renwnd32", vbNullString)

  If (SendMessageTimeout(lhwnd, WM_NULL, 0, 0, SMTO_ABORTIFHUNG, 10, 0) = 0) Then

    GetWindowThreadProcessId hwnds(lcount) , pid
    hp = OpenProcess(PROCESS_ALL_ACCESS, 0&, pid)
    TerminateProcess hp&, 0&
    CloseHandle hp

  End If

[Nucleus]

I edited the post, try the edited code.

[Stevie]

Cheers (again)

[Nucleus]

I take it worked?

[Stevie]

It compiles!

I won't be able to tell until later on today, as I can't get access to a specific mailbox at the moment.

I will let you know how it goes, as soon as I've been able to test it.