Desktop Declarations
First, we create a module with API declarations related to desktop creation and desktop switching.
Private Const DESKTOP_SECURE As Long = 131527 Private Const DESKTOP_SWITCHDESKTOP As Long = 256 Private Const SND_ASYNC As Long = 1 Private Const SND_NOSTOP As Long = 16 Private Const SND_PURGE As Long = 64 Private Const SND_FILENAME As Long = 131072 Private Const SPI_SETDESKWALLPAPER As Long = 20 Private Const SPIF_UPDATEINIFILE As Long = 1 Private Const SPIF_SENDWININICHANGE As Long = 2 Private Const DESKTOP_LOGON As String = "Winlogon" Private Const DESKTOP_WINSTATION0 As String = "WinSta0" Private Const DESKTOP_DEFAULT As String = "Default" Private Type SECURITY_ATTRIBUTES nLength As Long _ lpSecurityDescriptor As Long _ bInheritHandle As Long End Type Private Declare Function apiCloseDesktop Lib "user32" Alias _ "CloseDesktop" (ByVal hDesktop As Long) As Long Private Declare Function apiCreateDesktop Lib "user32" Alias _ "CreateDesktopA" (ByVal lDesktop As String, ByVal lDevice _ As Long, ByVal devmode As Long, ByVal dwFlags As Long, ByVal _ desiredAccess As Long, ByRef secAttribute As _ SECURITY_ATTRIBUTES) As Long Private Declare Function apiGetCurrentThreadId Lib "kernel32" _ Alias "GetCurrentThreadId" () As Long Private Declare Function apiGetDC Lib "user32" Alias "GetDC" _ (ByVal hWnd As Long) As Long Private Declare Function apiGetProcessWindowStation Lib "user32" _ Alias "GetProcessWindowStation" () As Long Private Declare Function apiGetSystemDirectory Lib "kernel32" _ Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, _ ByVal nSize As Long) As Long Private Declare Function apiGetThreadDesktop Lib "user32" _ Alias "GetThreadDesktop" (ByVal dwThread As Long) As Long Private Declare Function apiGetWindowDC Lib "user32" _ Alias "GetWindowDC" (ByVal hWnd As Long) As Long Private Declare Function apiOpenInputDesktop Lib "user32" _ Alias "OpenInputDesktop" (ByVal dwFlags As Long, _ ByVal fInherit As Boolean, ByVal dwDesiredAccess As Long) _ As Long Private Declare Function apiPaintDesktop Lib "user32" Alias _ "PaintDesktop" (ByVal hDC As Long) As Long Private Declare Function apiPlaySound Lib "winmm" Alias _ "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, _ ByVal dwFlags As Long) As Long Private Declare Function apiSetThreadDesktop Lib "user32" Alias _ "SetThreadDesktop" (ByVal hDesktop As Long) As Long Private Declare Function apiSwitchDesktop Lib "user32" Alias _ "SwitchDesktop" (ByVal hDesktop As Long) As Long Private Declare Function apiSystemParametersInfo Lib "user32" _ Alias "SystemParametersInfoA" (ByVal uAction As Long, _ ByVal uParam As Long, ByVal lParam As String, _ ByVal fuWinIni As Long) As Long Private Declare Function apiWaitForSingleObject Lib "kernel32" _ Alias "WaitForSingleObject" (ByVal hHandle As Long, _ ByVal dwMilliseconds As Long) As Long Private oldDskThread As Long Private oldDskInput As Long Private hwnDsk As Long
Primary Functions
Next, we wrap up the primary APIs into convenient functions.
Public Function CreateDesktop(ByVal sDesktopName As String) _ As Long On Error Resume Next Dim sa As SECURITY_ATTRIBUTES hwnDsk = _ apiCreateDesktop(sDesktopName, ByVal 0, ByVal 0, 0, _ DESKTOP_SECURE, sa) If hwnDsk = 0 Then CreateDesktop = 0: Exit Function CreateDesktop = hwnDsk End Function Public Function SwitchToDeskTop() As Long On Error Resume Next Dim st As Long Dim sd As Long st = apiSetThreadDesktop(hwnDsk) _ sd = apiSwitchDesktop(hwnDsk) If sd <> 0 Then _ SwitchToDeskTop = 1 End Function Public Sub CloseDeskTop() On Error Resume Next apiCloseDesktop (hwnDsk) End Sub
Secure Desktop Prompt Message
Finally, we create a function that ties it all together. This function prompts the actual user at the keyboard/mouse with a question to authorize or deny privileges. Because applications are currently suspended on the default desktop, we can be sure that the user has clicked “Yes” to the question displayed on the Message Box.
Public Function PromptMessageUAC(ByVal message As String, _ ByVal title As String, Optional ByVal timeout As Long) _ As MB_RESULT On Error Resume Next DoEvents Dim dskname As String Dim rn As Long Randomize rn = Rnd * (2147483647 - 1) + 1 _ dskname = CStr(rn) oldDskThread = apiGetThreadDesktop _ (apiGetCurrentThreadId) oldDskInput = _ apiOpenInputDesktop(0, False, DESKTOP_SWITCHDESKTOP) If CreateDesktop(dskname) = 0 Then Exit Function SwitchToDeskTop PromptMessageUAC = MessageBoxShow(message, _ title, MB_YES_NO_SECURE, 20000, 0) CloseDeskTop _ apiSetThreadDesktop (oldDskThread) apiSwitchDesktop _ (oldDskInput) DoEvents End Function
Message Box API
In a separate module, we declare the API and constants for a Message Box with optional timeout, similar to that of the UAC dialog timeout.
Private Const MB_OK As Long = &H0; Private Const MB_OKCANCEL As Long = &H1; Private Const MB_ABORTRETRYIGNORE As Long = &H2; Private Const MB_YESNOCANCEL As Long = &H3; Private Const MB_YESNO As Long = &H4; Private Const MB_RETRYCANCEL As Long = &H5; Private Const MB_MAX_TIMEOUT As Long = &HFFFFFFFF; Private Const MB_ICONERROR As Long = &H10; Private Const MB_ICONQUESTION As Long = &H20; Private Const MB_ICONWARNING As Long = &H30; Private Const MB_ICONINFORMATION As Long = &H40; Private Const MB_SERVICE_NOTIFICATION As Long = &H200000; Public Const MB_YES_NO_SECURE As Long = MB_YESNO Or _ MB_ICONQUESTION Or MB_SERVICE_NOTIFICATION Public Enum MB_RESULT IOK = 1 ICANCEL = 2 IABORT = 3 IRETRY = 4 _ IIGNORE = 5 IYES = 6 INO = 7 ITRYAGAIN = 10 ICONTINUE = 11 End Enum Private Declare Function apiMessageBoxTimeOut Lib "user32" _ Alias "MessageBoxTimeoutA" (ByVal prmlngWindowHandle As Long, _ ByVal prmstrMessage As String, ByVal prmstrCaption As String, _ ByVal prmlngType As Long, ByVal prmwLanguage As Integer, _ ByVal prmdwMiliseconds As Long) As Long Public Function MessageBoxShow(ByVal message As String, _ ByVal Caption As String, ByVal flags As Long, _ ByVal TimeOutMilliseconds As Long, ByVal hWnd As Long) _ As MB_RESULT On Error GoTo poop MessageBoxShow = apiMessageBoxTimeOut(hWnd, _ message, Caption, flags, 0, TimeOutMilliseconds) Exit Function poop: MessageBoxShow = -1 End Function
Usage
To use the main function, you would simply set the parameters of the function and read its return value. The following example sets the timeout to 20 seconds (i.e., 20000 milliseconds):
Private Sub Command1_Click() Dim o As MB_RESULT o = _ PromptMessageUAC("Are you sure?", "Secure message _ transaction", 20000) If o = MB_RESULT.IYES Then MsgBox "User is sure" ElseIf o = MB_RESULT.INO Then MsgBox "user is unsure" ElseIf o = 32000 Then MsgBox "User did not decide. _ Message box has timed out" ElseIf IsNumeric(o) = False Then MsgBox o End If End Sub