lohvinenko
asked on
Preventing VB to continue when shelled to a Dos Application
O.K. I know how to shell to an application and prevent the VB from continuing in a Windows 16 bit environment:
Declare Function GetModuleUseage% Lib "Kernel" (by Val hModule%)
Function LaunchApp(appname As String) As Integer
Static iRet%, iRet2%
iRet% = Shell(appname, vbMaximizedFocus)
On Error GoTo launch
While GetModuleUsage(iRet%)
iRet2% = DoEvents()
Wend
launch:
LaunchApp = iRet%
End Function
But how do I do it in a 32 bit application?
GetModuleUsage is not apart of the Kernel32 library :(
Declare Function GetModuleUseage% Lib "Kernel" (by Val hModule%)
Function LaunchApp(appname As String) As Integer
Static iRet%, iRet2%
iRet% = Shell(appname, vbMaximizedFocus)
On Error GoTo launch
While GetModuleUsage(iRet%)
iRet2% = DoEvents()
Wend
launch:
LaunchApp = iRet%
End Function
But how do I do it in a 32 bit application?
GetModuleUsage is not apart of the Kernel32 library :(
ASKER
Wrong answer.
I want to know how to call a dos based application from a shell and have the vb program wait until the process is done.
eg.
taskid = shell( "c:\test\pkzip.exe stuff.zip" , 1 )
while (GetModuleUsage(hMod))
Do Events
Wend
Problem GetModuleUsage is not part of the kernel32.dll.
this functiononly works in a WIN16 app not a WIN32!
Where do i go from here??
I want to know how to call a dos based application from a shell and have the vb program wait until the process is done.
eg.
taskid = shell( "c:\test\pkzip.exe stuff.zip" , 1 )
while (GetModuleUsage(hMod))
Do Events
Wend
Problem GetModuleUsage is not part of the kernel32.dll.
this functiononly works in a WIN16 app not a WIN32!
Where do i go from here??
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
No, my answer is good, you need to use the "ShellWait" function.
It works perfectly, and I have added more functions for your information.
It works perfectly, and I have added more functions for your information.
Option Explicit
' File and Disk functions.
Private Const DRIVE_CDROM = 5
Private Const DRIVE_FIXED = 3
Private Const DRIVE_RAMDISK = 6
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_UNKNOWN = 0 'Unknown, or unable to be determined.
Private Declare Function GetDriveTypeA Lib "kernel32" (ByVal nDrive As String) As Long
Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)
Private Declare Function GetWindowsDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPathA Lib "kernel32" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileNameA Lib "kernel32" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetSystemDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Const UNIQUE_NAME = &H0
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpdirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_HIDE = 0 ' = vbHide
Private Const SW_SHOWNORMAL = 1 ' = vbNormal
Private Const SW_SHOWMINIMIZED = 2 ' = vbMinimizeFocus
Private Const SW_SHOWMAXIMIZED = 3 ' = vbMaximizedFocus
Private Const SW_SHOWNOACTIVATE = 4 ' = vbNormalNoFocus
Private Const SW_MINIMIZE = 6 ' = vbMinimizedNofocus
Private Declare Function GetShortPathNameA Lib "kernel32" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_SILENT = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type STARTUPINFO
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
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpdirectory As String, ByVal lpResult As String) As Long
Private Declare Function SetVolumeLabelA Lib "kernel32" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long
' *** Get running applications
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Const GW_CHILD = 5
Const GW_HWNDFIRST = 0
Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2
Const GW_HWNDPREV = 3
Const GW_MAX = 5
Const GW_OWNER = 4
' *** Infos about files
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function GetFileInformationByHandle
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Const OFS_MAXPATHNAME = 128
Public Const OF_READ = &H0
Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME
End Type
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type BY_HANDLE_FILE_INFORMATION
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
dwVolumeSerialNumber As Long
nFileSizeHigh As Long
nFileSizeLow As Long
nNumberOfLinks As Long
nFileIndexHigh As Long
nFileIndexLow As Long
End Type
' *** RegisterAsServiceProcess
Public Declare Function RegisterServiceProcess Lib "kernel32.dll" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Public Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Public Function FindExecutable(s As String) As String
' Finds the executable associated with a file
'
' Returns "" if no file is found.
Dim i As Integer
Dim s2 As String
s2 = String(256, 32) & Chr$(0)
i = FindExecutableA(s & Chr$(0), vbNullString, s2)
If i > 32 Then
FindExecutable = Left$(s2, InStr(s2, Chr$(0)) - 1)
Else
FindExecutable = ""
End If
End Function
Public Function ShellDelete(ParamArray vntFileName() As Variant) As Boolean
'
' Deletes a single file, or an array of files to the trashcan.
'
Dim i As Integer
Dim sFileNames As String
Dim SHFileOp As SHFILEOPSTRUCT
For i = LBound(vntFileName) To UBound(vntFileName)
sFileNames = sFileNames & vntFileName(i) & vbNullChar
Next
sFileNames = sFileNames & vbNullChar
With SHFileOp
.wFunc = FO_DELETE
.pFrom = sFileNames
.fFlags = FOF_ALLOWUNDO + FOF_SILENT + FOF_NOCONFIRMATION
End With
i = SHFileOperation(SHFileOp)
If i = 0 Then
ShellDelete = True
Else
ShellDelete = False
End If
End Function
Public Function ShellWait(cCommandLine As String) As Boolean
' #VBIDEUtils#**************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 2/10/98
' * Time : 09:48
' * Module Name : Execute_Module
' * Module Filename : Execute.bas
' * Procedure Name : ShellWait
' * Parameters :
' * cCommandLine As String
' **************************
' * Comments :
' * Runs a command as the Shell command does but waits for the command
' * to finish before returning. Note: The full path and filename extention
' * is required.
' * You might want to use Environ$("COMSPEC") & " /c " & command
' * if you wish to run it under the command shell (and thus it)
' * will search the path etc...
' *
' * returns false if the shell failed
' *
' **************************
Dim NameOfProc As PROCESS_INFORMATION
Dim NameStart As STARTUPINFO
Dim i As Long
NameStart.cb = Len(NameStart)
i = CreateProcessA(0&, cCommandLine, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, NameStart, NameOfProc)
If i <> 0 Then
Call WaitForSingleObject(NameOf
Call CloseHandle(NameOfProc.hPr
ShellWait = True
Else
ShellWait = False
End If
End Function
Public Sub MonitorProcess(sProcess As String)
' *** check if another application is still running
Dim pId As Long
Dim pHnd As Long
pId = Shell(sProcess, vbNormalFocus)
pHnd = OpenProcess(SYNCHRONIZE, 0, pId) ' get Process Handle
If pHnd <> 0 Then
Call WaitForSingleObject(pHnd, INFINITE) ' Wait until shelled prog ends
Call CloseHandle(pHnd)
End If
End Sub
Public Function ExecuteWait(s As String, Optional Param As Variant) As Boolean
'
' As the Execute function but waits for the process to finish before
' returning
'
' returns true on success.
Dim s2 As String
s2 = FindExecutable(s)
If s2 <> "" Then
ExecuteWait = ShellWait(s2 & IIf(IsMissing(Param), " ", " " & CStr(Param) & " ") & s)
Else
ExecuteWait = False
End If
End Function
Public Function AddBackslash(s As String) As String
'
' Adds a backslash if the string doesn't have one already.
'
If Len(s) > 0 Then
If Right$(s, 1) <> "\" Then
AddBackslash = s + "\"
Else
AddBackslash = s
End If
Else
AddBackslash = "\"
End If
End Function
Public Function ExecuteWithAssociate(ByVal
' #VBIDEUtils#**************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 9/10/98
' * Time : 11:48
' * Module Name : Execute_Module
' * Module Filename : Execute.bas
' * Procedure Name : ExecuteWithAssociate
' * Parameters :
' * ByVal hWnd As Long
' * S As String
' * Optional Param As Variant
' * Optional windowstyle As Variant
' **************************
' * Comments :
' * Executes a file with it's associated program.
' * windowstyle uses the same constants as the Shell function:
' * vbHide 0
' * vbNormalFocus 1
' * vbMinimizedFocus 2
' * vbMaximizedFocus 3
' * vbNormalNoFocus 4
' * vbMinimizedNoFocus 6
' *
' * returns true on success
' *
' *
' **************************
Dim i As Long
If IsMissing(windowstyle) Then windowstyle = vbNormalFocus
i = ShellExecute(hwnd, vbNullString, sExecute, IIf(IsMissing(Param) Or (Param = ""), vbNullString, CStr(Param)), GetPath(sExecute), CLng(windowstyle))
If i > 32 Then
ExecuteWithAssociate = True
Else
ExecuteWithAssociate = False
End If
End Function
Public Function GetFile(s As String) As String
'
' Returns the file portion of a file + pathname
'
Dim i As Integer
Dim J As Integer
i = 0
J = 0
i = InStr(s, "\")
Do While i <> 0
J = i
i = InStr(J + 1, s, "\")
Loop
If J = 0 Then
GetFile = ""
Else
GetFile = Right$(s, Len(s) - J)
End If
End Function
Public Function GetPath(s As String) As String
'
' Returns the path portion of a file + pathname
'
Dim i As Integer
Dim J As Integer
i = 0
J = 0
i = InStr(s, "\")
Do While i <> 0
J = i
i = InStr(J + 1, s, "\")
Loop
If J = 0 Then
GetPath = ""
Else
GetPath = Left$(s, J)
End If
End Function
Public Function GetSerialNumber(sDrive As String) As Long
' *** Retrieve a disks serial number
' *** Whenever a disk is formatted, the operating system writes a serial number onto it.
' *** This number is not guaranteed to be unique, but as it is a 32 bit integer
' *** it is unlikely to find a duplicate!
' *** The number is often used as part of a copy protection system.
Dim nSerial As Long
Dim sTmp As String * 256
Dim sTmp2 As String * 256
Dim nI As Long
Dim nJ As Long
sTmp = String$(255, Chr$(0))
sTmp2 = String$(255, Chr$(0))
Call GetVolumeInformation(sDriv
GetSerialNumber = nSerial
End Function
Public Function GetSerialNumber2() As String
'
' Returns a volume's serial number
'
Dim lpReOpenBuff As OFSTRUCT
Dim FileHandle As Long
Dim FileInfo As BY_HANDLE_FILE_INFORMATION
Dim ret As Long
FileHandle = OpenFile("c:\autoexec.bat"
ret = GetFileInformationByHandle
GetSerialNumber2 = CStr(FileInfo.dwVolumeSeri
ret = CloseHandle(FileHandle)
End Function
Public Function GetShortPathName(longpath As String) As String
Dim s As String
Dim i As Long
i = Len(longpath) + 1
s = String(i, 0)
GetShortPathNameA longpath, s, i
GetShortPathName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function
Public Function GetVolumeName(sDrive As String) As String
Dim ser As Long
Dim s As String * 256
Dim s2 As String * 256
Dim i As Long
Dim J As Long
Call GetVolumeInformation(sDriv
GetVolumeName = Left$(s, InStr(s, Chr$(0)) - 1)
End Function
Public Function SetVolumeName(sDrive As String, n As String) As Boolean
'
' Sets the volume name. Returns true on success, false on failure.
'
Dim i As Long
i = SetVolumeLabelA(sDrive + ":\" & Chr$(0), n & Chr$(0))
SetVolumeName = IIf(i = 0, False, True)
End Function
Public Function GetSystemDirectory() As String
'
' Returns the system directory.
'
Dim s As String
Dim i As Integer
i = GetSystemDirectoryA("", 0)
s = Space(i)
Call GetSystemDirectoryA(s, i)
GetSystemDirectory = AddBackslash(Left$(s, i - 1))
End Function
'
' Returns the path to the temp directory.
'
Public Function GetTempPath() As String
Dim s As String
Dim i As Integer
i = GetTempPathA(0, "")
s = Space(i)
Call GetTempPathA(i, s)
GetTempPath = AddBackslash(Left$(s, i - 1))
End Function
Public Function GetWindowsDirectory() As String
'
' Returns the windows directory.
'
Dim s As String
Dim i As Integer
i = GetWindowsDirectoryA("", 0)
s = Space(i)
Call GetWindowsDirectoryA(s, i)
GetWindowsDirectory = AddBackslash(Left$(s, i - 1))
End Function
Public Function RemoveBackslash(s As String) As String
'
' Removes the backslash from the string if it has one.
'
Dim i As Integer
i = Len(s)
If i <> 0 Then
If Right$(s, 1) = "\" Then
RemoveBackslash = Left$(s, i - 1)
Else
RemoveBackslash = s
End If
Else
RemoveBackslash = ""
End If
End Function
Public Function sDriveType(sDrive As String) As String
'
' Returns the drive type if possible.
'
Dim lRet As Long
lRet = GetDriveTypeA(sDrive & ":\")
Select Case lRet
Case 0
'sDriveType = "Cannot be determined!"
sDriveType = "Unknown"
Case 1
'sDriveType = "The root directory does not exist!"
sDriveType = "Unknown"
Case DRIVE_CDROM:
sDriveType = "CD-ROM Drive"
Case DRIVE_REMOVABLE:
sDriveType = "Removable Drive"
Case DRIVE_FIXED:
sDriveType = "Fixed Drive"
Case DRIVE_REMOTE:
sDriveType = "Remote Drive"
End Select
End Function
Public Function GetDriveType(sDrive As String) As Long
Dim lRet As Long
lRet = GetDriveTypeA(sDrive & ":\")
If lRet = 1 Then
lRet = 0
End If
GetDriveType = lRet
End Function
Public Sub GetRunningApplications(nhw
' *** Show all the running applications
Dim lLgthChild As Long
Dim sNameChild As String
Dim lLgthOwner As Long
Dim sNameOwner As String
Dim lHwnd As Long
Dim lHwnd2 As Long
Dim lProssId As Long
Const vbTextCompare = 1
lHwnd = GetWindow(nhwnd, GW_HWNDFIRST)
While lHwnd <> 0
lHwnd2 = GetWindow(lHwnd, GW_OWNER)
lLgthOwner = GetWindowTextLength(lHwnd2
sNameOwner = String$(lLgthOwner + 1, Chr$(0))
lLgthOwner = GetWindowText(lHwnd2, sNameOwner, lLgthOwner + 1)
If lLgthOwner <> 0 Then
sNameOwner = Left$(sNameOwner, InStr(1, sNameOwner, Chr$(0), vbTextCompare) - 1)
Call GetWindowThreadProcessId(l
Debug.Print sNameOwner, lProssId
End If
lLgthChild = GetWindowTextLength(lHwnd)
sNameChild = String$(lLgthChild + 1, Chr$(0))
lLgthChild = GetWindowText(lHwnd, sNameChild, lLgthChild + 1)
If lLgthChild <> 0 Then
sNameChild = Left$(sNameChild, InStr(1, sNameChild, Chr$(0), vbTextCompare) - 1)
Call GetWindowThreadProcessId(l
Debug.Print sNameChild, lProssId
End If
lHwnd = GetWindow(lHwnd, GW_HWNDNEXT)
DoEvents
Wend
End Sub
Public Function RegisterAsServiceProcess(b
' #VBIDEUtils#**************
' * Programmer Name : Waty Thierry
' * Web Site : www.geocities.com/ResearchTriangle/6311/
' * E-Mail : waty.thierry@usa.net
' * Date : 25/09/98
' * Time : 11:36
' * Module Name : Execute
' * Module Filename : Execute_Module
' * Procedure Name : RegisterAsServiceProcess
' * Parameters :
' **************************
' * Comments : This code allows the programer to register
' * the application as a service process.
' * To put it in simpler terms, a service process does not appear in the "End Task"
' * dialog box. Using this call does not let the user of your application terminate
' * the program using Ctrl-Alt-Del.
' *
' **************************
RegisterAsServiceProcess = RegisterServiceProcess(Get
End Function