Clsapplauncher

Another ready2use class

Sample:
Sub click(source as Button)
Dim A As New AppLauncher
Msgbox A.Run("c:temptest.xls")
end sub

Starts EXCEL with File "test.xls"

return codes :

0 = OK
-1 = something wrong with the application
-2 = file, drive or dir does not exist

You do not have to do all that Registry stuff seen eleswhere in this database.
This is all done by an Windows-API call.

Private Type PROCESS_INFORMATION 'Structure used by CreateProcess
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type

Private Type STARTUPINFO 'Structure used by CreateProcess
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Declare Private Function CloseHandle Lib "kernel32" (Byval hObject As Long) As Long
Declare Private Function WaitForSingleObject Lib "kernel32" (Byval hHandle As Long, Byval dwMilliseconds As Long) As Long
Declare Private Function CreateProcessByNum Lib "kernel32" Alias "CreateProcessA" (Byval lpApplicationName As Long, Byval lpCommandLine As String, _
Byval lpProcessAttributes As Long, Byval lpThreadAttributes As Long, Byval bInheritHandles As Long, Byval dwCreationFlags As Long, lpEnvironment As Long, _
Byval lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (Byval lpFile As String, Byval lpDirectory As String, Byval lpResult As String) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20 'Constant used by CreateProcess
Private Const WAIT_TIMEOUT = &H102& 'Constant used by WaitForSingleObject

Class AppLauncher

Declare Private Function FindExByFileName(Byval Datei As String) As String
Declare Private Sub StopWaitingForApp(Source As NotesTimer)
Declare Private Function LaunchWithApp(Byval strAppName As String, Byval strCmdLine As String, Byval intSecondsToWait As Integer) As Integer
Declare Public Function ExistFileDirDrive(FilePathName As String) As Integer
Declare Public Function Run(FileName As String) As Integer

Public Function Run(FileName As String) As Integer
If ExistFileDirDrive(FileName) Then
Run = LaunchWithApp(FindExByFileName(FileName),"", 0)
Else
Run = -2
End If
End Function

Private Function LaunchWithApp(Byval strAppName As String, Byval strCmdLine As String, Byval intSecondsToWait As Integer) As Integer

Dim lngRES As Long
Dim sinfo As STARTUPINFO
Dim pinfo As PROCESS_INFORMATION

On Error Goto WaitForApp_Err

WaitForApp = True

'Set up the timer for the maximum time we want to wait for the app to terminate
Set timWaitForApp = New NotesTimer(intSecondsToWait, "Maximum time to wait for app to terminate")
On Event Alarm From timWaitForApp Call StopWaitingForApp
intContinueWaitingForApp = True 'This will be set to False in StopWaitingForApp() if timer interval is reached

sinfo.cb = Len(sinfo)
sinfo.lpReserved = Chr$(0)
sinfo.lpDesktop = Chr$(0)
sinfo.lpTitle = Chr$(0)
sinfo.dwFlags = 0
'sinfo.wShowWindow = SW_HIDE

Print "Launching " & strAppName & "."
lngRES = CreateProcessByNum(0, strAppName & " " & strCmdLine, 0, 0, True, NORMAL_PRIORITY_CLASS, (0&), 0, sinfo, pinfo)
If lngRES Then
'Don't need the thread handle
Call CloseHandle(pinfo.hThread)
Print strAppName & " launched. Waiting for termination..."
Do
lngRES = WaitForSingleObject(pinfo.hProcess, 0)
If lngRES <> WAIT_TIMEOUT Then
'No timeout returned from Windows, app is terminated.
Exit Do
End If
Doevents
Loop While intContinueWaitingForApp

If Not intContinueWaitingForApp Then
'If the operation timed out
WaitForApp = False
Msgbox strAppName & " did not complete in a reasonable amount of time.", 0 + 64, "Called application could not complete"
Else
Print strAppName & " terminated."
End If
'Kill the last handle of the process
Call CloseHandle(pinfo.hProcess)
Else
WaitForApp = False
Msgbox "Error running " & strAppName & ".", 0 + 64, "ERROR"
End If

WaitForApp_Exit:

'Kill the timer if necessary
If Not timWaitForApp Is Nothing Then
Set timWaitForApp = Nothing
End If
Exit Function

WaitForApp_Err:

WaitForApp = False
Msgbox Error$ & " (" & Cstr(Err) & ").", 0 + 64, "ERROR"
Resume WaitForApp_Exit

End Function

Private Function FindExByFileName(Byval Datei As String) As String
Dim Pfad As String
Pfad = Space$(256)
FindExecutable Datei, vbNullString, Pfad
FindExByFileName = Trim(Pfad)
End Function

Private Sub StopWaitingForApp(Source As NotesTimer)
intContinueWaitingForApp = False
End Sub

Public Function ExistFileDirDrive(FilePathName As String) As Integer
Dim nTest As String

nTest = Lcase$(FilePathName)
If Len(nTest) = 1 Then
Select Case Left$(nTest, 1)
Case "a" To "z"
nTest = FilePathName & ":"
End Select
Elseif Len(nTest) = 2 Then
Select Case Left$(nTest, 2)
Case "a:" To "z:"
nTest = FilePathName & ""
End Select
End If
On Error Resume Next
ExistFileDirDrive = Cint(Getattr(nTest) )
End Function

End Class