У меня Outlook 2016 (64-разрядная версия), выполняющий следующий код VBA, и при выходе из функции Outlook вылетает.API работает нормально, и я вижу, что блокнот запущен под другим пользователем.
Sub TestRunAs()
If User_RunAs("jonny", "JonnysPassword", "lvd.be", "c:\windows\notepad.exe") Then
MsgBox ("Ok, executed!")
End If
End Sub
Это функция;
Public Function User_RunAs(ByVal sUserName As String, ByVal sPassword As String, ByVal sDomain As String, ByVal sCommand As String) As Boolean
Dim lReturn As Long
Dim sApplication As String
Dim sDirectory As String
Dim tPInfo As PROCESS_INFORMATION
Dim tStart As STARTUPINFO
'/* default struct
sApplication = vbNullString
sDirectory = vbNullString
tStart.Cb = LenB(tStart)
tStart.dwFlags = 0&
lReturn = CreateProcessWithLogonW(StrPtr(sUserName), StrPtr(sDomain), StrPtr(sPassword), &H1, _
0&, StrPtr(sCommand), _
DEFAULT_LOGON, 0&, StrPtr(sDirectory), _
tStart, tPInfo)
' 1st row LongPtr LongPtr LongPtr Long
' 2nd row Long LongPtr
' 3rd row Long Long LongPtr
' 4th row Structure Structure
'/* success
If Not lReturn = 0 Then
User_RunAs = True
End If
'/* cleanup
If tPInfo.hProcess <> 0 Then
CloseHandle tPInfo.hThread
CloseHandle tPInfo.hProcess
End If
End Function
Это определение следующее:
'Types used by function User_RunAs
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 Long
lpDesktop As Long
lpTitle As Long
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 Declare PtrSafe Function CreateProcessWithLogonW Lib "advapi32" (ByVal lpUserName As LongPtr, ByVal lpDomain As LongPtr, ByVal lpPassword As LongPtr, ByVal dwLogonFlags As Long, _
ByVal lpApplicationName As Long, ByVal lpCommandLine As LongPtr, _
ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As LongPtr, _
ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInfo As PROCESS_INFORMATION) As Long
Даже при выходе из функции сразу после вызова API Outlook выходит из строя со следующим отчетом;