用VB实现GM服务端启动器-同时启动多个EXE进程

原版是Delphi写的有一点瑕疵，由于热心网游的邀约，用VB重写了一个。代码如下创建进程的VB代码如下。这里有一个要注意的地方就是 当前目录这参数。

注意 这个CurrentDir参数  这个参数 如果不写的话，对于大部分程序是没问题的，但是 对于传奇服务端来说 必须要写，因为服务端会通过这个参数来读取目录下的配置文档，如果读取不了的话，程序就无法启动。

Option Explicit

'另一个程序可以这样写
'
'Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineA" () As Long
'Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
'Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
'
'Public Function vbCommandLine() As String
'        Dim length As Long, pstr As Long
'        pstr = GetCommandLine() '获取字符串的指针
'        length = lstrlen(pstr) '获取字符串的长度
'        vbCommandLine = String(length + 1, 0) '调整字符串的大小
'        lstrcpy vbCommandLine, pstr '复制字符串
'End Function
'
'
'Private Sub Form_Load()
'    Me.Caption = vbCommandLine()
'End Sub
'

Private Type PROCESS_INFORMATION
        hProcess As Long
        hThread As Long
        dwProcessId As Long
        dwThreadId As Long
End Type

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 SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" ( _
  ByVal lpApplicationName As String, _
  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 lpCurrentDriectory As String, _
  lpStartupInfo As STARTUPINFO, _
  lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'0019F0D0   00000020  |CreationFlags = NORMAL_PRIORITY_CLASS

Public Const NORMAL_PRIORITY_CLASS = &H20&

'
'
'Public Function VB创建进程(ByVal sCommandLine As String) As Long
'  Shell sCommandLine
'End Function
'

Public Function 获取文件名(ByVal exePath As String) As String

   Dim fpath As String
   
   fpath = LCase(exePath)

   If InStr(fpath, "\") > 0 And InStr(fpath, ".exe") > 0 Then
        Dim arr
        arr = VBA.Split(Trim(exePath), "\")
        
        Dim ret As Long
        ret = UBound(arr)
        
        获取文件名 = arr(ret)
    Else
        
        获取文件名 = ""
    End If

End Function

Public Function VB创建进程(ByVal sCommandLine As String) As Long
  Dim sInfo As STARTUPINFO
  Dim psInfo As PROCESS_INFORMATION
  Dim pAttr As SECURITY_ATTRIBUTES
  Dim tAttr As SECURITY_ATTRIBUTES
  Dim nRet As Long
  Dim nElapse As Integer
  sInfo.cb = &H44&
  sInfo.dwFlags = 1
    sInfo.wShowWindow = 1
  

'  psInfo.hProcess = 2
'
'
'
'
'        psInfo.hThread = 0
'
'           psInfo.dwProcessId = &HF&

' psInfo.dwThreadId = &H1D0000

' 0019F0D8   033D2D58  |CurrentDir = "C:\Users\Administrator\Desktop"

Dim CurrentDir As String

Dim FileNameexe As String

FileNameexe = "\" & 获取文件名(sCommandLine)
 
CurrentDir = VBA.Replace(sCommandLine, FileNameexe, "")

  
  nRet = CreateProcess(vbNullString, sCommandLine, 0, 0, False, NORMAL_PRIORITY_CLASS, 0, CurrentDir, sInfo, psInfo) '注意 这个CurrentDir参数  这个参数 如果不写的话，对于大半部分程序是没问题的，但是 对于传奇服务端来说 必须要写，因为服务端会通过
'    If nRet = 0 Then
'           VB创建进程 = 0
'           Exit Function
'    End If
''  nElapse = 0
'
'    nRet = WaitForSingleObject(psInfo.hProcess, 1000)
'    If nRet = 0 Then
''      MsgBox "Done!"
'      Exit Function
'    End If
'

'do {
'    Sleep(100);
'    Res = WaitForSingleObject(Process.hProcess, 10);
'} while (Res == WAIT_TIMEOUT);

While (nRet > 10000)

    SleepEx 100
    nRet = WaitForSingleObject(psInfo.hProcess, 1000)

    DoEvents
  Wend

'       If g是否是首个程序 = 1 Then
'            g游戏盒子网关进程句柄 = psInfo.hProcess
'        End If

 ' VB创建进程 = 1
End Function

VB技术交流QQ群：214016721