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
Start the conversation
0 comments