thread.bas

一套好的餐饮行业管理软件

Attribute VB_Name = "Module1"

'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 Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
 
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 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 String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
'关闭句柄
Private Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
'给出退出操作
Private Declare Function GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long

'外壳等待
Public Function ShellAndWait(ByVal strPath As String, ByVal iWindowStyle As Integer, ByRef lreturnCode As Long, Optional sWinTitle As String = "", Optional sDirectoryPath As String = "") As Boolean
 
  Dim proc As PROCESS_INFORMATION
  Dim start As STARTUPINFO
  Dim ret As Long
 
  'On Error GoTo ShellAndWaiterr
 
 ' 初始化启动结构
   start.cb = Len(start) '必须设置大小
   start.dwFlags = &H1& ' STARTF_USESHOWWINDOW 使用显示窗口
   start.wShowWindow = iWindowStyle
  
   If Not IsMissing(sWinTitle) Then
    '窗口标题
    start.lpTitle = sWinTitle
   End If
 
 ' 运行外部程序
   ret = CreateProcessA(0&, strPath, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, sDirectoryPath, start, proc)
 
 ' 等待外壳程序完成
   ret = WaitForSingleObject(proc.hProcess, 100&)
   
   Do While ret <> 0
      If ret < 0 Then
        ShellAndWait = False
        Exit Function
      End If
 
      DoEvents
 
      ret = WaitForSingleObject(proc.hProcess, 100&)
   
   Loop
 
  '给出返回的代码
   ret = GetExitCodeProcess(proc.hProcess, lreturnCode)
  '关闭操作
   ret = CloseHandle(proc.hProcess)
   ShellAndWait = True
   Exit Function
 
ShellAndWaiterr:
   ShellAndWait = False
   Exit Function
   Resume
End Function