Private Const LOGON_WITH_PROFILE = &H1&
Private Const CREATE_DEFAULT_ERROR_MODE = &H4000000
Private Const CREATE_NEW_CONSOLE = &H10&
Private Const CREATE_NEW_PROCESS_GROUP = &H200&
Private Const CREATE_SEPARATE_WOW_VDM = &H800&
Private Const CREATE_SUSPENDED = &H4&
Private Const CREATE_UNICODE_ENVIRONMENT = &H400&
Public Structure STARTUPINFO
Dim cb As Integer
<MarshalAs(UnmanagedType.LPTStr)> _
Dim lpReserved As String
<MarshalAs(UnmanagedType.LPTStr)> _
Dim lpDesktop As String
<MarshalAs(UnmanagedType.LPTStr)> _
Dim lpTitle As String
Dim dwX As Integer
Dim dwY As Integer
Dim dwXSize As Integer
Dim dwYSize As Integer
Dim dwXCountChars As Integer
Dim dwYCountChars As Integer
Dim dwFillAttribute As Integer
Dim dwFlags As Integer
Dim wShowWindow As Short
Dim cbReserved2 As Short
Dim lpReserved2 As Integer
Dim hStdInput As Integer
Dim hStdOutput As Integer
Dim hStdError As Integer
End Structure
Public Structure PROCESS_INFORMATION
Dim hProcess As Integer
Dim hThread As Integer
Dim dwProcessId As Integer
Dim dwThreadId As Integer
End Structure
<DllImport("Advapi32.dll")> _
Public Shared Function CreateProcessWithLogonW( _
<MarshalAs(UnmanagedType.LPWStr)> ByVal lpUsername As String, _
<MarshalAs(UnmanagedType.LPWStr)> ByVal lpDomain As String, _
<MarshalAs(UnmanagedType.LPWStr)> ByVal lpPassword As String, _
ByVal dwLogonFlags As Integer, _
<MarshalAs(UnmanagedType.LPWStr)> ByVal lpApplicationName As String, _
<MarshalAs(UnmanagedType.LPWStr)> ByVal lpCommandLine As String, _
ByVal lpCreationFlags As Integer, _
ByVal lpEnvironment As IntPtr, _
<MarshalAs(UnmanagedType.LPWStr)> ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInfo As PROCESS_INFORMATION) As Boolean
End Function
<DllImport("kernel32.dll")> _
Public Shared Function CloseHandle( _
ByVal hObject As Long) As Long
End Function
'指定されたプロセスの終了ステータスを取得します
<DllImport("kernel32.dll", SetLastError:=True)> _
Public Function GetExitCodeProcess(ByVal process As Integer, ByRef exitCode As UInt32) As Boolean
End Function
'指定されたカーネルオブジェクトがシグナル状態になるか、指定された時間が経過するまでスレッドをスリープさせます
<DllImport("Kernel32.dll", SetLastError:=True)> _
Public Function WaitForSingleObject(ByVal handle As Integer, ByVal milliseconds As UInt32) As UInt32
End Function
'The FormatMessage function formats a message string that is passed as input.
<DllImport("kernel32.dll")> _
Public Function FormatMessage(ByVal dwFlags As Integer, ByRef lpSource As IntPtr, _
ByVal dwMessageId As Integer, ByVal dwLanguageId As Integer, ByRef lpBuffer As [String], _
ByVal nSize As Integer, ByRef Arguments As IntPtr) As Integer
End Function
'実行
Public Sub RunAs(ByVal t As Task, ByVal logPath As String)
Dim processInfo As PROCESS_INFORMATION
Dim startupInfo As STARTUPINFO = New STARTUPINFO
Dim retval As Boolean
Try
startupInfo.cb = System.Runtime.InteropServices.Marshal.SizeOf(startupInfo)
startupInfo.lpTitle = Nothing
startupInfo.dwYCountChars = 50
retval = CreateProcessWithLogonW( _
t.UserName, t.Domain, t.PassWord, _
LOGON_WITH_PROFILE, Nothing, t.Command, _
CREATE_DEFAULT_ERROR_MODE Or CREATE_NEW_CONSOLE Or CREATE_NEW_PROCESS_GROUP, _
IntPtr.Zero, Nothing, _
startupInfo, processInfo)
Dim wait As System.UInt32 = Convert.ToUInt32(60000)
Dim exitCode As System.UInt32
'終了まで60秒内で待つ
WaitForSingleObject(processInfo.hProcess, wait)
'終了コード取得
GetExitCodeProcess(processInfo.hProcess, exitCode)
'終了コードが異常だった場合
If exitCode.ToString = "0" Then
'エラーコード取得
Dim ret As Integer = Marshal.GetLastWin32Error()
'エラーメッセージに変換
Dim errmsg As String = GetErrorMessage(ret)
WriteLog("Error : " & errmsg, logPath)
End If
Catch ex As Exception
WriteLog("実行時エラー" & ex.ToString, logPath)
Finally
If retval = True Then
CloseHandle(processInfo.hProcess)
CloseHandle(processInfo.hThread)
End If
End Try
End Sub
Private Function GetErrorMessage(ByVal errorCode As Integer) As String
Dim FORMAT_MESSAGE_ALLOCATE_BUFFER As Integer = &H100 '関数に、バッファの割り当てを要求します
Dim FORMAT_MESSAGE_IGNORE_INSERTS As Integer = &H200 'パラメータを無視するよう要求します
Dim FORMAT_MESSAGE_FROM_SYSTEM As Integer = &H1000 'システムメッセージテーブルリソースを使用するよう要求します
Dim msgSize As Integer = 255
Dim lpMsgBuf As String
Dim dwFlags As Integer = FORMAT_MESSAGE_ALLOCATE_BUFFER _
Or FORMAT_MESSAGE_FROM_SYSTEM _
Or FORMAT_MESSAGE_IGNORE_INSERTS
Dim lpSource As IntPtr = IntPtr.Zero
Dim lpArguments As IntPtr = IntPtr.Zero
Dim returnVal As Integer = _
FormatMessage(dwFlags, lpSource, errorCode, 0, lpMsgBuf,msgSize, lpArguments)
If returnVal = 0 Then
Throw New Exception("Failed to format message for error code " + errorCode.ToString() + ". ")
End If
Return lpMsgBuf
End Function
|
