Introduction

A professional looking on screen keyboard, is not as easy to make as one might think. The little steps along the way, can lead to absurd time consuming snags. This article should save you a lot of time and help you build a sturdy foundation for your own osk.

History

It's been almost two years since I wrote an article about sending keyboard messages to applications. I got a ton of emails, and other positive feedback from it.

In this article I will be using an updated Sendkeys module, from that article. The modules come in two flavors, classic VB6 and VB.NET 2005. It's also largely compatible with 64 bit operating systems. The sample osk included with this article was built to compete head-to-head with the Windows 7 On-Screen keyboard, and win!

Key features

1. XP/Vista/7 (32-64 bit) compatible.
2. UAC(User Account Control) compliant.
3. Starts at login(welcome screen), to provide basic keyboard functionality.
4. Text completion.
5. Text to speech, capable of using external voices on all compatible OS.
6. Low profile layout, maximizes desktop work space.
7. Prevents other windows from lying underneath, and vice versa. More accesible than using the "Always On Top" option, which is commonly used in other programs.
8. Alternate functions(Fn), can be used to change the volume, or power down windows. Can also resize, move, maximize, or close the window in focus, by pressing a single function button.
9. Customizable gradient color themes are aero(Vista Windows 7)capable, with optional translucency.
10. Menu shortcuts, allow you to launch frequently used programs.

Head-to-Head

(X, poor, fair, good, excellent)

Focus

In the last article, keyboard focus was of utmost importance, and it still is. However, an on screen keyboard must avoid keyboard focus from ever reaching the keyboard itself. Focus must remain on the window that the keys are being sent to. There are a few ways to achieve this, but I prefer using a mouse hook. This allows you to do a little more customization of the mouse input events.

So first we setup some constants, structures, functions, and a delegate.

Const HC_ACTION As Int32 = 0
Const HC_GETNEXT As Int32 = 1
Const WM_LBUTTONDOWN As Int32 = 513
Const WM_LBUTTONUP As Int32 = 514
Const WM_RBUTTONDOWN As Int32 = 516
Const WM_RBUTTONUP As Int32 = 517
Const WM_MBUTTONDOWN As Int32 = 519
Const WM_MBUTTONUP As Int32 = 520
Const WM_MOUSEWHEEL As Int32 = 522
Const WM_MOUSEMOVE As Int32 = 512
Const WH_MOUSE_LL As Int32 = 14
Public Structure POINTAPI
    Public X, Y As Int32
End Structure
Private Structure MOUSEHOOKSTRUCT
    Public pt As POINTAPI
    Public hwnd, wHitTestCode, dwExtraInfo As Int32
End Structure
Private Declare Function apiSetWindowsMouseHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Int32, _
ByVal lpfn As MouseHookDelegate, _
ByVal hmod As Int32, _
ByVal dwThreadId As Int32) As Int32
Private Declare Function apiUnhookWindowsHookEx Lib "user32" _
Alias "UnhookWindowsHookEx" _
(ByVal hHook As Int32) As Int32
Private Declare Function apiCallNextMouseHookEx Lib "user32" _
Alias "CallNextHookEx" _
(ByVal hHook As Int32, _
ByVal nCode As Int32, _
ByVal wParam As Int32, _
ByVal lParam As MOUSEHOOKSTRUCT) As Int32
Private Delegate Function MouseHookDelegate _
(ByVal nCode As Int32, _
ByVal wParam As Int32, _
ByRef lParam As MOUSEHOOKSTRUCT) As Int32
 Private mCallback As MouseHookDelegate
Private MouseHandle, wfpWnd As Int32

These two functions are called to start and end the mouse hook.

Private Function MouseHook() As Boolean
  On Error Resume Next
  mCallback = New MouseHookDelegate(AddressOf MouseCallback)
  MouseHandle = apiSetWindowsMouseHookEx _
  (WH_MOUSE_LL, mCallback, _
  Runtime.InteropServices.Marshal.GetHINSTANCE _
  (Reflection.Assembly.GetExecutingAssembly.GetModules()(0)) _
  .ToInt32, 0)
  Return CBool(MouseHandle)
End Function

Private Function MouseUnHook() As Boolean
    On Error Resume Next
    MouseHandle = apiUnhookWindowsHookEx(MouseHandle)
    Return Not CBool(MouseHandle)
End Function

You'll probably want to hook/unhook the mouse when loading/unloading the form like this.

Private Sub Form1_Load _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles MyBase.Load
    MouseHook()
End Sub

Private Sub Form1_FormClosed _
(ByVal sender As Object, _
ByVal e As System.Windows.Forms.FormClosedEventArgs) Handles Me.FormClosed
    MouseUnHook()
End Sub

This is the actual function that handles mouse events, right before they are sent to an application. This is the place to intercept, block, and redirect mouse input.

Private Function MouseStroke(ByRef hStruct As MOUSEHOOKSTRUCT, ByVal wParam As Int32) As Boolean
    On Error Resume Next
    If wParam = WM_LBUTTONDOWN Then
        wfpWnd = WindowFromPoint()
        If wfpWnd = Button1.Handle.ToInt32 Then
            Return SendKeys.KeyEvent(Keys.D0)
        ElseIf wfpWnd = Button2.Handle.ToInt32 Then
            Return SendKeys.KeyEvent(Keys.D1)
        End If
    ElseIf wParam = WM_LBUTTONUP Then
        '
    ElseIf wParam = WM_RBUTTONDOWN Then
        '
    ElseIf wParam = WM_RBUTTONUP Then
        '
    ElseIf wParam = WM_MOUSEMOVE Then
        '
    Else
        '
    End If
End Function

This is a simple callback for the MouseStroke function above.

Private Function MouseCallback _
(ByVal Code As Int32, ByVal wParam As Int32, ByRef lParam As MOUSEHOOKSTRUCT) As Int32
    On Error Resume Next
    If Code = HC_ACTION AndAlso MouseStroke(lParam, wParam) = True Then Return HC_GETNEXT
    Return apiCallNextMouseHookEx(MouseHandle, Code, wParam, lParam)
End Function

A VB6 module for the mouse hook, would look something like this.

Option Explicit
Const HC_ACTION As Long = 0
Const HC_GETNEXT As Long = 1
Const WH_MOUSE_LL As Long = 14
Const WM_LBUTTONDOWN As Long = 513
Const WM_LBUTTONUP As Long = 514
Const WM_RBUTTONDOWN As Long = 516
Const WM_RBUTTONUP As Long = 517
Const WM_MOUSEMOVE As Long = 512
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    hWnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type
Private Declare Function apiCallNextMouseHookEx Lib "user32" Alias "CallNextHookEx" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByRef pDest As MOUSEHOOKSTRUCT, _
ByVal pSource As Long, _
ByVal cb As Long) As Long
Private Declare Function apiSetWindowsMouseHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal mHookDel As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function apiUnhookWindowsHookEx Lib "user32" Alias "UnhookWindowsHookEx" _
(ByVal hHook As Long) As Long
Private phwnd As Long
Private MouseHandle As Long

Public Function HookIt() As Boolean
    On Error Resume Next
    MouseHandle = apiSetWindowsMouseHookEx _
    (WH_MOUSE_LL, AddressOf MouseCallback, App.hInstance, 0)
End Function

Public Function UnHookIt() As Boolean
    On Error Resume Next
    MouseHandle = apiUnhookWindowsHookEx(MouseHandle)
End Function

Public Function MouseCallback _
(ByVal Code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    Static hStruct As MOUSEHOOKSTRUCT
    Call apiCopyMemory(hStruct, lParam, Len(hStruct))
    If Code = HC_ACTION Then
        If wParam = WM_LBUTTONDOWN Then
            phwnd = WindowFromPoint
            
            If phwnd = frmOSK.Command1.hWnd Then
                SendKeys.KeyEvent (Keys.vk_d0)
                MouseCallback = HC_GETNEXT
                Exit Function
            ElseIf phwnd = frmOSK.Command2.hWnd Then
                SendKeys.KeyEvent (Keys.vk_d1)
                MouseCallback = HC_GETNEXT
                Exit Function
            Else
                '
            End If

        ElseIf wParam = WM_LBUTTONUP Then
        '
        ElseIf wParam = WM_RBUTTONDOWN Then
        '
        ElseIf wParam = WM_RBUTTONUP Then
        '
        End If
    End If
    MouseCallback = apiCallNextMouseHookEx _
    (MouseHandle, Code, wParam, lParam)
End Function

No windows underneath

Some programs have an option called "Always On Top", which allows them to stay above less important windows, that do not have such an option. If two programs do have this same option, the effect is somewhat nullified.

There is certainly room for improvement, to continually ensure top most status of your osk. However, this can be an inferior design because your osk may be laying on top of the window that you want to send input to.

If the option is not used, then the window may lay on top of your osk instead. The user is then forced to move windows around, so that they may see the window with keyboard focus, and the keyboard at the same time.

The solution, is to move those windows from under the keyboard, and place them gently into the largest available space on the desktop. Maximized windows must also be taken into consideration, since they will end up under the keyboard, which hides their status bar area.

The following code demonstrates how to move other windows out, from underneath your form into the desktop work area. You could repeat this in a thread or timer sub procedure.

   Const ABS_AUTOHIDE As Int32 = 1
   Const ABS_ONTOP As Int32 = 2
   Const ABM_GETSTATE As Int32 = 4
   Const ABM_GETTASKBARPOS As Int32 = 5
   Const GWL_STYLE As Int32 = -16
   Const WS_POPUP As Int32 = -2147483648
   Const WS_BORDER As Int32 = 8388608
   Const WS_SYSMENU As Int32 = 524288
   Const WS_POPUPWINDOW As Int32 = _
   (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
   Private Structure WINDOWNAME
       Public lpText, lpClassName As String
   End Structure
   Public Structure RECT
       Public rLeft, rTop, rRight, rBottom As Int32
   End Structure
   Private Structure TASKBARINFO
       Public isTop, isBottom, isLeft, isRight As Boolean
       Public autoHide, alwaysTop As Boolean
       Public hwnd, width, height As Int32
       Public top, bottom, left, right As Int32
   End Structure
   Private Structure APPBARDATA
       Public cbSize, hwnd, uCallbackMessage, uEdge As Int32
       Public rc As RECT, lParam As Int32
   End Structure
   Private Declare Function apiMoveWindow Lib _
   "user32" Alias "MoveWindow" _
   (ByVal hWnd As Int32, _
   ByVal x As Int32, _
   ByVal y As Int32, _
   ByVal nWidth As Int32, _
   ByVal nHeight As Int32, _
   ByVal bRepaint As Boolean) As Boolean
   Private Declare Function apiGetWindowRect Lib _
   "user32" Alias "GetWindowRect" _
   (ByVal hWnd As Int32, _
   ByRef lpRect As RECT) As Boolean
   Private Declare Function apiGetWindowText Lib _
   "user32" Alias "GetWindowTextA" _
   (ByVal hWnd As Int32, _
   ByVal lpString As String, _
   ByVal cch As Int32) As Int32
   Private Declare Function apiGetWindowTextLength Lib _
   "user32" Alias "GetWindowTextLengthA" _
   (ByVal hWnd As Int32) As Int32
   Private Declare Function apiEnumWindows Lib _
   "user32" Alias "EnumWindows" _
   (ByVal lpEnumFunc As EnumFuncDeleg, _
   ByVal lParam As Int32) As Int32
   Private Declare Function apiIsWindowVisible Lib _
   "user32" Alias "IsWindowVisible" _
   (ByVal hWnd As Int32) As Boolean
   Private Declare Function apiIsIconic Lib _
   "user32" Alias "IsIconic" _
   (ByVal hWnd As Int32) As Boolean
   Private Declare Function apiIsZoomed Lib _
   "user32" Alias "IsZoomed" _
   (ByVal hWnd As Int32) As Boolean
   Private Declare Function apiGetWindowLong Lib _
   "user32" Alias "GetWindowLongA" _
   (ByVal hwnd As Int32, _
   ByVal nIndex As Int32) As Int32
   Private Declare Function apiFindWindow Lib _
   "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, _
   ByVal lpWindowName As String) As Int32
   Private Declare Function apiGetClassName Lib _
   "user32" Alias "GetClassNameA" _
   (ByVal hWnd As Int32, _
   ByVal lpClassName As String, _
   ByVal nMaxCount As Int32) As Int32
   Private Declare Function apiSHAppBarMessage Lib _
   "shell32" Alias "SHAppBarMessage" _
   (ByVal dwMessage As Int32, _
   ByRef pData As APPBARDATA) As Int32
   Private Declare Function apiGetKeyState Lib _
   "user32" Alias "GetKeyState" _
   (ByVal vKey As Int32) As Int32
   Private Delegate Function EnumFuncDeleg _
   (ByVal hwnd As Int32, _
   ByVal lpData As Int32) As Int32
   Private wText As String

   Private Sub Button1_Click _
   (ByVal sender As System.Object, _
   ByVal e As System.EventArgs) Handles Button1.Click
       apiEnumWindows(AddressOf NoWindows, 0)
   End Sub

   Private Function NoWindows _
   (ByVal hwnd As Int32, ByVal lpData As Int32) As Int32
       NoWindows = 1 'set return
       'If window is visible and not minimized
       If apiIsWindowVisible(hwnd) = True AndAlso apiIsIconic(hwnd) = False Then
           wText = GetWindowText(hwnd)  'Get the title
           'Found top-level window that has a title, and is not the desktop progman
           If wText <> "" AndAlso wText <> "Program Manager" Then
               'if the window is not this program, then make sure it's not under us
               If hwnd <> Me.Handle.ToInt32 Then NoWinBeneath(Me.Handle.ToInt32, hwnd)
           End If
       End If
   End Function

    Private Function NoWinBeneath(ByVal twnd As Int32, ByVal hwnd As Int32) As Boolean
       On Error Resume Next
       Dim fHeight, fWidth As Int32
       Dim r, r2 As New RECT
       Dim d As New Size
       Dim tb As New TASKBARINFO
       apiGetWindowRect(hwnd, r)
       apiGetWindowRect(twnd, r2)
       fHeight = (r.rBottom - r.rTop)
       fWidth = (r.rRight - r.rLeft)
       If fWidth < 1 OrElse fHeight < 1 Then Exit Function
       d = My.Computer.Screen.WorkingArea.Size
       tb = GetTaskBarInfo(False)
       If apiIsZoomed(hwnd) = True Then 'Maximized
           If tb.isBottom = True Then
               'If area above the osk has more room fit it there
               If (r2.rTop - 0) > (tb.top - r2.rBottom) Then
                   apiMoveWindow _
                   (hwnd, 0, 0, d.Width, (r2.rTop - 0), True)
               Else 'If below has more room
                   apiMoveWindow _
                   (hwnd, 0, r2.rBottom, d.Width, (tb.top - r2.rBottom), True)
               End If
           ElseIf tb.isLeft Then
               'If area above the osk has more room fit it there
               If (r2.rTop - 0) > (d.Height - r2.rBottom) Then
                   apiMoveWindow _
                   (hwnd, tb.right, 0, d.Width, (r2.rTop - 0), True)
               Else 'If below has more room
                   apiMoveWindow _
                   (hwnd, tb.right, r2.rBottom, d.Width, (d.Height - r2.rBottom), True)
               End If
           ElseIf tb.isRight Then
               'If area above the osk has more room fit it there
               If (r2.rTop - 0) > (d.Height - r2.rBottom) Then
                   apiMoveWindow _
                   (hwnd, 0, 0, d.Width, (r2.rTop - 0), True)
               Else 'If below has more room
                   apiMoveWindow _
                   (hwnd, 0, r2.rBottom, d.Width, (d.Height - r2.rBottom), True)
               End If
           ElseIf tb.isTop Then
               'If area above the osk has more room fit it there
               If (r2.rTop - tb.bottom) > (d.Height - r2.rBottom) Then
                   apiMoveWindow _
                   (hwnd, 0, tb.bottom, d.Width, (r2.rTop - tb.bottom), True)
               Else 'If below has more room
                   apiMoveWindow _
                   (hwnd, 0, r2.rBottom, d.Width, (d.Height - r2.rBottom) + tb.height, True)
               End If
           End If
       Else 'If not maximized, could be normal or a popup
           Dim topWorkArea, botWorkArea As Int32
           If tb.isTop = True Then
               topWorkArea = (r2.rTop - tb.bottom)
               botWorkArea = d.Height - (r2.rBottom - tb.height)
           Else
               topWorkArea = r2.rTop
               botWorkArea = (d.Height - r2.rBottom)
           End If
           'If area above the osk has more room fit the foreground there
           If topWorkArea > botWorkArea Then
               'If foreground bottom below our top(MOVE IT)
               If r.rBottom > r2.rTop AndAlso ((r.rLeft < r2.rLeft AndAlso r.rRight > r2.rLeft) _
               OrElse (r.rLeft > r2.rLeft AndAlso r.rLeft < r2.rRight)) Then
                   If fHeight <= topWorkArea Then 'Will fit move it into the area
                       apiMoveWindow(hwnd, r.rLeft, (r2.rTop - fHeight), fWidth, fHeight, True)
                   Else 'If height to big for available upper realestate see if it's shrinkable
                       'if not a popup then it's shrinkable
                       If WS_POPUPWINDOW <> _
                       (apiGetWindowLong(hwnd, GWL_STYLE) And WS_POPUPWINDOW) Then
                           If tb.isTop = True Then
                               apiMoveWindow _
                               (hwnd, r.rLeft, tb.bottom, fWidth, topWorkArea, True)
                           Else
                               apiMoveWindow _
                               (hwnd, r.rLeft, 0, fWidth, topWorkArea, True)
                           End If
                       Else 'if is popup can't shrink those
                           If tb.isTop = True Then
                               apiMoveWindow _
                               (hwnd, r.rLeft, tb.bottom, fWidth, fHeight, True)
                           Else
                               apiMoveWindow _
                               (hwnd, r.rLeft, 0, fWidth, fHeight, True)
                           End If
                       End If
                   End If
               End If
           Else 'If below our form has more area
               'If foreground top above our bottom(MOVE IT)
               If r.rTop < r2.rBottom AndAlso ((r.rLeft < r2.rLeft AndAlso r.rRight > r2.rLeft) _
               OrElse (r.rLeft > r2.rLeft AndAlso r.rLeft < r2.rRight)) Then
                   If fHeight <= botWorkArea Then 'Will fit move it into the area
                       apiMoveWindow(hwnd, r.rLeft, r2.rBottom, fWidth, fHeight, True)
                   Else 'If height to big for available realestate see if it's shrinkable
                       'if not a popup then it's shrinkable
                       If WS_POPUPWINDOW <> _
                       (apiGetWindowLong(hwnd, GWL_STYLE) And WS_POPUPWINDOW) Then
                           If tb.isTop = True Then
                               apiMoveWindow _
                               (hwnd, r.rLeft, r2.rBottom, fWidth, botWorkArea, True)
                           Else
                               apiMoveWindow _
                               (hwnd, r.rLeft, r2.rBottom, fWidth, botWorkArea, True)
                           End If
                       Else 'if is popup can't shrink those
                           If tb.isTop = True Then
                               apiMoveWindow _
                               (hwnd, r.rLeft, (d.Height - fHeight) + tb.height, fWidth, fHeight, True)
                           Else
                               apiMoveWindow _
                               (hwnd, r.rLeft, (d.Height - fHeight), fWidth, fHeight, True)
                           End If
                       End If
                   End If
               End If
           End If
       End If
   End Function

    Private Function GetWindowText(ByVal hWnd As Int32) As String
        On Error Resume Next
        Dim tLength, rValue As Int32
        tLength = apiGetWindowTextLength(hWnd) + 4
        GetWindowText = ""
        GetWindowText = GetWindowText.PadLeft(tLength)
        rValue = apiGetWindowText(hWnd, GetWindowText, tLength)
        GetWindowText = GetWindowText.Substring(0, rValue)
    End Function

    Private Function GetTaskBarInfo _
    (ByVal getAppearance As Boolean) As TASKBARINFO
        On Error Resume Next
        Dim ret As Int32, d As New Size, r As New RECT
        Dim hwnd As Int32 = apiFindWindow("Shell_TrayWnd", Nothing)
        apiGetWindowRect(hwnd, r)
        GetTaskBarInfo.hwnd = hwnd
        GetTaskBarInfo.height = (r.rBottom - r.rTop)
        GetTaskBarInfo.width = (r.rRight - r.rLeft)
        GetTaskBarInfo.top = r.rTop
        GetTaskBarInfo.bottom = r.rBottom
        GetTaskBarInfo.left = r.rLeft
        GetTaskBarInfo.right = r.rRight
        d = My.Computer.Screen.WorkingArea.Size
        If r.rTop = 0 AndAlso r.rBottom = d.Height Then 'TaskBar Position
            If r.rLeft < (d.Width / 2) Then
                GetTaskBarInfo.isLeft = True '''''''''''''''' left
            Else
                GetTaskBarInfo.isRight = True ''''''''''''''''right
            End If
        Else
            If r.rTop < (d.Height / 2) Then
                GetTaskBarInfo.isTop = True ''''''''''''''''top
            Else
                GetTaskBarInfo.isBottom = True ''''''''''''''''bottom
            End If
        End If
        If getAppearance = False Then Exit Function
        ret = apiSHAppBarMessage(ABM_GETSTATE, Nothing)
        If ret = ABS_AUTOHIDE OrElse ret = ABS_ONTOP + ABS_AUTOHIDE Then
            GetTaskBarInfo.autoHide = True
        End If
        If CDbl(Environment.OSVersion.VersionString.Substring(21, 3)) > 6.0 Then
            If ret = 0 Then GetTaskBarInfo.alwaysTop = True
        Else
            If ret = ABS_ONTOP OrElse ret = ABS_ONTOP + ABS_AUTOHIDE Then
                GetTaskBarInfo.alwaysTop = True
            End If
        End If
    End Function

Here is that same code in a VB6 module.

Const SPI_GETWORKAREA As Long = 48
Const ABS_AUTOHIDE As Long = 1
Const ABS_ONTOP As Long = 2
Const ABM_GETSTATE As Long = 4
Const ABM_GETTASKBARPOS As Long = 5
Const WS_POPUP As Long = &H80000000
Const WS_BORDER As Long = 8388608
Const WS_SYSMENU As Long = 524288
Const WS_POPUPWINDOW As Long = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Const GWL_STYLE As Long = -16
Private Type WINDOWNAME
    lpText As String
    lpClassName As String
End Type
Private Type RECT
    rLeft As Long
    rTop As Long
    rRight As Long
    rBottom As Long
End Type
Private Type TASKBARINFO
     isTop As Boolean
     isBottom As Boolean
     isLeft As Boolean
     isRight As Boolean
     autoHide As Boolean
     alwaysTop As Boolean
     hwnd As Long
     width As Long
     height  As Long
     top As Long
     bottom As Long
     left As Long
     right As Long
End Type
Private Type APPBARDATA
    cbSize As Long
    hwnd As Long
    uCallbackMessage As Long
    uEdge As Long
    rc As RECT
    lParam As Long
End Type
Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Boolean) As Boolean
Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Boolean
Private Declare Function apiGetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function apiGetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" _
(ByVal hwnd As Long) As Long
Private Declare Function apiIsZoomed Lib "user32" Alias "IsZoomed" _
(ByVal hwnd As Long) As Boolean
Private Declare Function apiGetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function apiFindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function apiGetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function apiSHAppBarMessage Lib "shell32" Alias "SHAppBarMessage" _
(ByVal dwMessage As Long, _
ByRef pData As APPBARDATA) As Long
Private Declare Function apiGetKeyState Lib "user32" Alias "GetKeyState" _
(ByVal vKey As Long) As Long
Private wText As String
Private Declare Function apiSystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
ByRef lpvParam As RECT, _
ByVal fuWinIni As Long) As Boolean
Private Declare Function apiIsWindowVisible Lib "user32" Alias "IsWindowVisible" _
(ByVal hwnd As Long) As Long
Private Declare Function apiIsIconic Lib "user32" Alias "IsIconic" _
(ByVal hwnd As Long) As Boolean
Public Declare Function apiEnumWindows Lib "user32" Alias "EnumWindows" _
(ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Boolean

Public Function NoWindows(ByVal hwnd As Long, ByVal lpData As Long) As Boolean
  NoWindows = True 'set return
  If apiIsWindowVisible(hwnd) = 0 Then Exit Function 'If window invisible
  If apiIsIconic(hwnd) = True Then Exit Function 'if minimized
  wText = GetWindowText(hwnd) 'Get the title
  'If top-level window has no title, 'or is the desktop progman
  If wText = "" Or wText = "Program Manager" Then Exit Function
  If hwnd = Form1.hwnd Then Exit Function 'if the window is this program
  Call NoWinBeneath(Form1.hwnd, hwnd) 'Move window from underneath
End Function

Private Function NoWinBeneath(ByVal twnd As Long, ByVal hwnd As Long) As Boolean
  On Error Resume Next
  Dim tb As TASKBARINFO
  Dim r As RECT
  Dim r2 As RECT
  Dim dr As RECT
  Dim fHeight As Long
  Dim fWidth As Long
  Dim dWidth As Long
  Dim dHeight As Long
  Dim mHeight As Long
  Call apiGetWindowRect(hwnd, r)
  Call apiGetWindowRect(twnd, r2)
  Call apiSystemParametersInfo(SPI_GETWORKAREA, 0, dr, 0)
  fHeight = (r.rBottom - r.rTop)
  fWidth = (r.rRight - r.rLeft)
  dWidth = dr.rRight - dr.rLeft
  dHeight = dr.rBottom - dr.rTop
  mHeight = r2.rBottom - r2.rTop
  tb = GetTaskBarInfo(False)
  If fHeight < 1 Or fWidth < 1 Then Exit Function
  If apiIsZoomed(hwnd) = True Then 'Maximized
      If tb.isBottom = True Then
          'If area above the osk has more room fit it there
          If (r2.rTop - 0) > (tb.top - r2.rBottom) Then
            Call apiMoveWindow _
            (hwnd, 0, 0, dWidth, (r2.rTop - 0), True)
          Else 'If below has more room
            Call apiMoveWindow _
            (hwnd, 0, r2.rBottom, dWidth, (tb.top - r2.rBottom), True)
          End If
      ElseIf tb.isLeft Then
          'If area above the osk has more room fit it there
          If (r2.rTop - 0) > (dHeight - r2.rBottom) Then
            Call apiMoveWindow _
            (hwnd, tb.right, 0, dWidth, (r2.rTop - 0), True)
          Else 'If below has more room
            Call apiMoveWindow _
            (hwnd, tb.right, r2.rBottom, dWidth, (dHeight - r2.rBottom), True)
          End If
      ElseIf tb.isRight Then
          'If area above the osk has more room fit it there
          If (r2.rTop - 0) > (dHeight - r2.rBottom) Then
            Call apiMoveWindow _
            (hwnd, 0, 0, dWidth, (r2.rTop - 0), True)
          Else 'If below has more room
            Call apiMoveWindow _
            (hwnd, 0, r2.rBottom, dWidth, (dHeight - r2.rBottom), True)
          End If
      ElseIf tb.isTop Then
          'If area above the osk has more room fit it there
          If (r2.rTop - tb.bottom) > (dHeight - r2.rBottom) Then
            Call apiMoveWindow _
            (hwnd, 0, tb.bottom, dWidth, (r2.rTop - tb.bottom), True)
          Else 'If below has more room
            Call apiMoveWindow _
            (hwnd, 0, r2.rBottom, dWidth, (dHeight - r2.rBottom) + tb.height, True)
          End If
      End If
  Else 'If not maximized, could be normal or a popup
      Dim topWorkArea, botWorkArea As Long
      If tb.isTop = True Then
          topWorkArea = (r2.rTop - tb.bottom)
          botWorkArea = dHeight - ((r2.rTop + mHeight) - tb.height)
      Else
          topWorkArea = r2.rTop
          botWorkArea = (dHeight - r2.rBottom)
      End If
      'If area above the osk has more room fit the foreground there
      If topWorkArea > botWorkArea Then
          'If foreground bottom below our top(MOVE IT)
          If r.rBottom > r2.rTop And _
          ((r.rLeft < r2.rLeft And r.rRight > r2.rLeft) Or _
          (r.rLeft > r2.rLeft And r.rLeft < r2.rRight)) Then
              If fHeight <= topWorkArea Then 'Will fit move it into the area
                  Call apiMoveWindow _
                  (hwnd, r.rLeft, (r2.rTop - fHeight), fWidth, fHeight, True)
              Else 'If height to big for available upper area
                  'if not a popup then it's shrinkable
                  If WS_POPUPWINDOW <> _
                  (apiGetWindowLong(hwnd, GWL_STYLE) And WS_POPUPWINDOW) Then
                      If tb.isTop = True Then
                          Call apiMoveWindow _
                          (hwnd, r.rLeft, tb.bottom, fWidth, topWorkArea, True)
                      Else
                          Call apiMoveWindow _
                          (hwnd, r.rLeft, 0, fWidth, topWorkArea, True)
                      End If
                  Else 'if is popup can't shrink those
                      If tb.isTop = True Then
                          Call apiMoveWindow _
                          (hwnd, r.rLeft, tb.bottom, fWidth, fHeight, True)
                      Else
                          Call apiMoveWindow _
                          (hwnd, r.rLeft, 0, fWidth, fHeight, True)
                      End If
                  End If
              End If
          End If
      Else 'If below our form has more area
         'If foreground top above our bottom(MOVE IT)
         If r.rTop < r2.rBottom And ((r.rLeft < r2.rLeft And r.rRight > r2.rLeft) _
         Or (r.rLeft > r2.rLeft And r.rLeft < r2.rRight)) Then
           If fHeight <= botWorkArea Then 'Will fit move it into the area
              Call apiMoveWindow _
              (hwnd, r.rLeft, r2.rBottom, fWidth, fHeight, True)
           Else 'If height to big for available realestate see if it's shrinkable
              'if not a popup then it's shrinkable
              If WS_POPUPWINDOW <> _
              (apiGetWindowLong(hwnd, GWL_STYLE) And WS_POPUPWINDOW) Then
                 If tb.isTop = True Then
                    Call apiMoveWindow _
                    (hwnd, r.rLeft, r2.rBottom, fWidth, botWorkArea, True)
                 Else
                    Call apiMoveWindow _
                    (hwnd, r.rLeft, r2.rBottom, fWidth, botWorkArea, True)
                 End If
              Else 'if is popup can't shrink those
                 If tb.isTop = True Then
                    Call apiMoveWindow _
                    (hwnd, r.rLeft, (dHeight - fHeight) + tb.height, fWidth, fHeight, True)
                 Else
                    Call apiMoveWindow _
                    (hwnd, r.rLeft, (dHeight - fHeight), fWidth, fHeight, True)
                 End If
              End If
           End If
         End If
      End If
  End If
End Function

Private Function GetWindowText(ByVal hwnd As Long) As String
  On Error Resume Next
  Dim tLength As Long
  Dim rValue As Long
  GetWindowText = ""
  tLength = apiGetWindowTextLength(hwnd) + 4 'Get length
  GetWindowText = Strings.Space(tLength) 'Pad with buffer
  rValue = apiGetWindowText(hwnd, GetWindowText, tLength) 'Get text
  GetWindowText = left(GetWindowText, rValue) 'Strip buffer
End Function

Private Function GetTaskBarInfo _
(ByVal getAppearance As Boolean) As TASKBARINFO
  On Error Resume Next
  Dim ret As Long
  Dim r As RECT
  Dim hwnd As Long
  Dim dr As RECT
  Dim dWidth As Long
  Dim dHeight As Long
  Call apiSystemParametersInfo(SPI_GETWORKAREA, 0, dr, 0)
  dWidth = dr.rRight - dr.rLeft
  dHeight = dr.rBottom - dr.rTop
  hwnd = apiFindWindow("Shell_TrayWnd", vbNullString)
  Call apiGetWindowRect(hwnd, r)
  GetTaskBarInfo.hwnd = hwnd
  GetTaskBarInfo.height = (r.rBottom - r.rTop)
  GetTaskBarInfo.width = (r.rRight - r.rLeft)
  GetTaskBarInfo.top = r.rTop
  GetTaskBarInfo.bottom = r.rBottom
  GetTaskBarInfo.left = r.rLeft
  GetTaskBarInfo.right = r.rRight
  If r.rTop = 0 And r.rBottom = dHeight Then 'TaskBar Position
      If r.rLeft < (dWidth / 2) Then
          GetTaskBarInfo.isLeft = True '''''''''''''''' left
      Else
          GetTaskBarInfo.isRight = True ''''''''''''''''right
      End If
  Else
      If r.rTop < (dHeight / 2) Then
          GetTaskBarInfo.isTop = True ''''''''''''''''top
      Else
          GetTaskBarInfo.isBottom = True ''''''''''''''''bottom
      End If
  End If
  If getAppearance = False Then Exit Function
  Dim abd As APPBARDATA
  ret = apiSHAppBarMessage(ABM_GETSTATE, abd)
  If ret = ABS_AUTOHIDE Or ret = ABS_ONTOP + ABS_AUTOHIDE Then
      GetTaskBarInfo.autoHide = True
  End If
  If CDbl(Environment.OSVersion.VersionString.Substring(21, 3)) > 6# Then
      If ret = 0 Then GetTaskBarInfo.alwaysTop = True
  Else
      If ret = ABS_ONTOP Or ret = ABS_ONTOP + ABS_AUTOHIDE Then
          GetTaskBarInfo.alwaysTop = True
      End If
  End If
End Function

The call to that module would look something like this.

Private Sub Command1_Click()
   Call apiEnumWindows(AddressOf NoWindows, 0)
End Sub

User Account Control

An elaborate on-screen keyboard might run into issues with the User Account Control. This might happen when installing third party text-to-speech voices. It can also happen if the osk is going to be started at the welcome screen.

The UAC is really not as secure as it was intended, and it's obviously not very user friendly. It can easily be bypassed, or auto-elevated by injecting into the memory space of a "white list" program, ie calc.exe explorer.exe.

The UAC can cause legitimate programs to fail for no apparent reason, including some Microsoft programs. The fact that it doesn't always protect, and sometimes prevents normal operation, presents a double whammy. Not to mention the overhead time it takes to open programs and windows with this extra step. The usability of Microsoft Windows, has been getting slower and slower since Windows 98.

In this demonstration we will ask the user for consent to turn off the UAC. A malware could just as easily trick you here, and turn it off regardless.

Const EWX_REBOOT As Int32 = 2
Private Declare Function apiRestartDialog Lib _
"shell32" Alias "RestartDialog" _
(ByVal hWnd As Int32, _
ByVal xPrompt As String, _
ByVal EWX_ As Int32) As Int32

Private Sub Form1_Load _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles MyBase.Load
 On Error Resume Next 'if vista/7
 If CDbl(Environment.OSVersion.VersionString.Substring(21, 3)) > 5.1 Then
   Dim dRes As New DialogResult
   If IsUACOn() = True Then
     dRes = MessageBox.Show _
     ("The UAC(User Account Control) is on." & vbCrLf & _
"It should be shut off for this application to install and work properly." _
     & vbCrLf & vbCrLf & "Would you like to install this program now?", _
     "User Account Control", MessageBoxButtons.OKCancel, _
     MessageBoxIcon.Question)
     If dRes = Windows.Forms.DialogResult.OK Then
        UACOFF()
     Else
        dRes = MessageBox.Show _
        ("This program should abort, unless the UAC is turned off." _
        & vbCrLf & vbCrLf & _
        "Are you sure that you want to abort the installation?", _
        "User Account Control", MessageBoxButtons.YesNo, _
        MessageBoxIcon.Question)
        If dRes = Windows.Forms.DialogResult.Yes Then
            Environment.Exit(0)
        Else
            UACOFF()
        End If
      End If
   End If
 End If
End Sub

Private Function IsUACOn() As Boolean
    On Error Resume Next
    Dim regkey As Microsoft.Win32.RegistryKey = Nothing
    regkey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey _
    ("SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System")
    'If UAC on in registry
    If CInt(regkey.GetValue("ConsentPromptBehaviorAdmin", 0)) = 2 Then IsUACOn = True
    If CInt(regkey.GetValue("EnableLUA", 0)) = 1 Then IsUACOn = True
    If CInt(regkey.GetValue("PromptOnSecureDesktop", 0)) = 1 Then IsUACOn = True
    regkey.Close()
End Function

Private Sub UACOFF()
    On Error Resume Next
    If TurnUACOFF() = False Then Exit Sub
    apiRestartDialog(Me.Handle.ToInt32, vbNullString, EWX_REBOOT)
    Environment.Exit(0)
End Sub

Private Function TurnUACOFF() As Boolean
    Dim regkey As Microsoft.Win32.RegistryKey = Nothing
    Try
        regkey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey _
        ("SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System", True)
        regkey.SetValue("ConsentPromptBehaviorAdmin", 0)
        regkey.SetValue("EnableLUA", 0)
        regkey.SetValue("PromptOnSecureDesktop", 0)
        regkey.Flush()
        If CInt(regkey.GetValue("ConsentPromptBehaviorAdmin", 0)) = 0 Then
            If CInt(regkey.GetValue("PromptOnSecureDesktop", 0)) = 0 Then
                If CInt(regkey.GetValue("EnableLUA", 0)) = 0 Then
                    TurnUACOFF = True
                End If
            End If
        End If
    Catch ex As Exception
        MessageBox.Show _
        (ex.Message & vbCrLf & _
        "Try right-clicking the application in the start menu, and then click, Run As Administrator")
        Environment.Exit(0)
    End Try
    regkey.Close()
End Function

If you are really uptight about using the registry to check if the UAC is on, then you can use API like this. I don't think you can shut it off with API though, so use the code above for that.

Imports System.Runtime.InteropServices
Module UACCheck
Const STANDARD_RIGHTS_REQUIRED As Int32 = 983040
Const TOKEN_ASSIGN_PRIMARY As Int32 = 1
Const TOKEN_DUPLICATE As Int32 = 2
Const TOKEN_IMPERSONATE As Int32 = 4
Const TOKEN_QUERY As Int32 = 8
Const TOKEN_QUERY_SOURCE As Int32 = 16
Const TOKEN_ADJUST_PRIVILEGES As Int32 = 32
Const TOKEN_ADJUST_GROUPS As Int32 = 64
Const TOKEN_ADJUST_DEFAULT As Int32 = 128
Const TOKEN_ADJUST_SESSIONID As Int32 = 256
Const TOKEN_ALL_ACCESS_P As Int32 = _
(STANDARD_RIGHTS_REQUIRED Or TOKEN_ASSIGN_PRIMARY Or _
    TOKEN_DUPLICATE Or TOKEN_IMPERSONATE Or TOKEN_QUERY Or _
    TOKEN_QUERY_SOURCE Or TOKEN_ADJUST_PRIVILEGES Or _
    TOKEN_ADJUST_GROUPS Or TOKEN_ADJUST_DEFAULT)
Public Structure TOKEN_ELEVATION
    Public TokenIsElevated As Int32
End Structure
Private Declare Function apiOpenProcessToken Lib _
    "advapi32" Alias "OpenProcessToken" _
    (ByVal ProcessHandle As Int32, _
    ByVal DesiredAccess As Int32, _
    ByRef TokenHandle As Int32) As Boolean
    Private Declare Function apiGetTokenInformation Lib _
    "advapi32" Alias "GetTokenInformation" _
    (ByVal TokenHandle As Int32, _
    ByVal TokenInformationClass As TOKEN_INFORMATION_CLASS, _
    ByVal TokenInformation As Int32, _
    ByVal TokenInformationLength As Int32, _
    ByRef ReturnLength As Int32) As Boolean
    Private Declare Function apiCloseHandle Lib _
    "kernel32" Alias "CloseHandle" _
    (ByVal hObject As Int32) As Boolean

Public Enum TOKEN_ELEVATION_TYPE
    TokenElevationTypeDefault = 1
    TokenElevationTypeFull = 2
    TokenElevationTypeLimited = 3
End Enum
Public Enum TOKEN_INFORMATION_CLASS
    TokenUser = 1
    TokenGroups = 2
    TokenPrivileges = 3
    TokenOwner = 4
    TokenPrimaryGroup = 5
    TokenDefaultDacl = 6
    TokenSource = 7
    TokenType = 8
    TokenImpersonationLevel = 9
    TokenStatistics = 10
    TokenRestrictedSids = 11
    TokenSessionId = 12
    TokenGroupsAndPrivileges = 13
    TokenSessionReference = 14
    TokenSandBoxInert = 15
    TokenAuditPolicy = 16
    TokenOrigin = 17
    TokenElevationType = 18
    TokenLinkedToken = 19
    TokenElevation = 20
    TokenHasRestrictions = 21
    TokenAccessInformation = 22
    TokenVirtualizationAllowed = 23
    TokenVirtualizationEnabled = 24
    TokenIntegrityLevel = 25
    TokenUIAccess = 26
    TokenMandatoryPolicy = 27
    TokenLogonSid = 28
    MaxTokenInfoClass = 29
End Enum

    Public Function IsVista() As Boolean
        Return (System.Environment.OSVersion.Version.Major >= 6)
    End Function

    Public Function IsElevated() As Boolean
        Dim bRetVal As Boolean = False
        Dim hToken As Int32 = 0
        Dim hProcess As Int32 = Process.GetCurrentProcess.Handle.ToInt32
        If hProcess = 0 Then Return False
        If apiOpenProcessToken(hProcess, TOKEN_QUERY, hToken) = False Then Return False
        Try
            Dim te As TOKEN_ELEVATION
            te.TokenIsElevated = 0
            Dim dwReturnLength As Int32 = 0
            Dim teSize As Int32 = Marshal.SizeOf(te)
            Dim tePtr As IntPtr = Marshal.AllocHGlobal(teSize)
            Try
                Marshal.StructureToPtr(te, tePtr, True)
                bRetVal = apiGetTokenInformation(hToken, TOKEN_INFORMATION_CLASS.TokenElevation, tePtr.ToInt32, teSize, dwReturnLength)
                If bRetVal = True AndAlso teSize = dwReturnLength Then
                    te = DirectCast(Marshal.PtrToStructure(tePtr, GetType(TOKEN_ELEVATION)), TOKEN_ELEVATION)
                Else
                    'error
                End If
            Finally
                Marshal.FreeHGlobal(tePtr)
            End Try
            Return (te.TokenIsElevated <> 0)
        Finally
            apiCloseHandle(hToken)
        End Try
    End Function

    Public Function GetElevationType() As TOKEN_ELEVATION_TYPE
        Dim bRetVal As Boolean = False
        Dim hToken As Int32 = 0
        Dim hProcess As Int32 = Process.GetCurrentProcess.Handle.ToInt32
        If hProcess = 0 Then Return Nothing
        If apiOpenProcessToken(hProcess, TOKEN_QUERY, hToken) = False Then Return Nothing
        Try
            Dim tet As TOKEN_ELEVATION_TYPE = TOKEN_ELEVATION_TYPE.TokenElevationTypeDefault
            Dim dwReturnLength As Int32 = 0
            Dim tetSize As Int32 = Marshal.SizeOf(CInt(tet))
            Dim tetPtr As IntPtr = Marshal.AllocHGlobal(tetSize)
            Try
                bRetVal = apiGetTokenInformation(hToken, TOKEN_INFORMATION_CLASS.TokenElevationType, tetPtr.ToInt32, tetSize, dwReturnLength)
                If bRetVal = True AndAlso tetSize = dwReturnLength Then
                    tet = DirectCast(Marshal.ReadInt32(tetPtr), TOKEN_ELEVATION_TYPE)
                Else
                    'error
                End If
            Finally
                Marshal.FreeHGlobal(tetPtr)
            End Try
            Return tet
        Finally
            apiCloseHandle(hToken)
        End Try
    End Function

End Module

The calls to the module above are quite simple.

    Private Sub Form1_Load _
    (ByVal sender As System.Object, _
    ByVal e As System.EventArgs) Handles MyBase.Load
        On Error Resume Next
        If IsVista() = True Then
            lbVista.Text = "I'm on Vista/7"
        Else
            lbVista.Text = "I'm not on Vista/7"
            Exit Sub
        End If
        If IsElevated() = True Then
            lbIsAdmin.Text = "I'm elevated"
        Else
            lbIsAdmin.Text = "I'm not elevated"
        End If
        Dim tet As TOKEN_ELEVATION_TYPE
        tet = GetElevationType()
        If tet = TOKEN_ELEVATION_TYPE.TokenElevationTypeDefault Then
            lbIsElevated.Text = "I'm standard user and/or UAC is disabled"
        ElseIf tet = TOKEN_ELEVATION_TYPE.TokenElevationTypeFull Then
            lbIsElevated.Text = "UAC is enabled and I'm elevated"
        ElseIf tet = TOKEN_ELEVATION_TYPE.TokenElevationTypeLimited Then
            lbIsElevated.Text = "UAC is enabled and I'm not elevated"
        End If
    End Sub

Registry key Ownership

If you want your osk to run at the welcome screen, so that the user can log into windows, then you'll need to take ownership of a particular registry key. When Windows was first installed on your machine, this registry key is owned by "TrustedInstaller". Administrators, do not have full access yet, nor ownership.

If the UAC(User Account Control) is on, then it's harder to programmatically take ownership of this key. During beta testing, I found that while running Windows 7 RC, the Microsoft program called "subinacl.exe", failed to gain ownership and access from the "TrustedInstaller".

I ended up using a work around, that gains administrative ownership and access, of this registry key, using automation.

Computer\HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Accessibility\ATs\osk

Private Sub Button1_Click _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles Button1.Click
  Dim sKey as String = "Computer\HKEY_LOCAL_MACHINE\SOFTWARE\"
  sKey = sKey & "Microsoft\Windows NT\CurrentVersion\"
  TakeOwnership (sKey & "Accessibility\ATs\osk")
End Sub

Private Function TakeOwnership _
(ByVal keyName As String) As Boolean
  On Error Resume Next
  Dim regkey As Microsoft.Win32.RegistryKey
  Dim w As New SendKeys.WINFOCUS
  regkey = Microsoft.Win32.Registry.CurrentUser.OpenSubKey _
  ("Software\Microsoft\Windows\CurrentVersion\Applets\Regedit", _
  True)
  regkey.SetValue("LastKey", keyName)
  regkey.Close()
  For Each p As Process In Process.GetProcesses
      If p.ProcessName = "regedit" Then p.Kill()
  Next
  apiWinExec("regedit.exe", SW_SHOWNORMAL)
  SendKeys.WaitForWindow("Registry Editor", 4000)
  SendKeys.Sleep(25, 25)
  apiBlockInput(True)
  SendKeys.ForceForeground _
  (SendKeys.apiFindWindowEx(0, 0, Nothing, "Registry Editor"))
  SendKeys.KeyEvent(Keys.Apps)
  SendKeys.KeyEvent(Keys.P)
  SendKeys.WaitForWindow("Permissions for osk", 4000)
  w.Foreground = apiFindWindowEx _
  (0, 0, Nothing, "Permissions for osk")
  If w.Foreground = 0 Then apiBlockInput(False) : Exit Function
  Do
    Threading.Thread.Sleep(200)
    w = GetWinHandles("Permissions for osk", 1, "Security", 1)
    If w.Foreground = 0 Then apiBlockInput(False) : Exit Function
    If w.Focus <> 0 Then Exit Do
  Loop
  SendKeys.KeyEvent(Keys.A) 'swoop to administrators. 
  SendKeys.Sleep(25, 25)
  w = GetWinHandles _
 ("Permissions for osk", 1, "Security", 1, "CHECKLIST_ACLUI", 1, _
  "Allow Full Control", 1)
  If w.Focus = 0 Then apiBlockInput(False) : Exit Function
  SendKeys.Message(Keys.Space, w, True, True, True)
  SendKeys.Sleep(25, 25)
  w = GetWinHandles _
  ("Permissions for osk", 1, "Security", 1, "Advanced", 1)
  SendKeys.Message(Keys.Space, w, True, True, True)
  SendKeys.WaitForWindow("Advanced Security Settings for osk", 4000)
  SendKeys.Sleep(25, 25)
  w.Foreground = apiFindWindowEx _
  (0, 0, Nothing, "Advanced Security Settings for osk")
  w.Focus = w.Foreground
  If w.Foreground = 0 Then apiBlockInput(False) : Exit Function
  Dim r As New RECT
  apiGetWindowRect(w.Foreground, r)
  apiSetCursorPos(r.rLeft + 153, r.rTop + 50)
  SendKeys.MouseEvent(Buttons.LeftClick)
  SendKeys.Sleep(25, 25)
  w = GetWinHandles _
  ("Advanced Security Settings for osk", 1, "Owner", 1)
  If w.Focus = 0 Then apiBlockInput(False) : Exit Function
  w.Focus = apiFindWindowEx(w.Focus, 0, "SysListView32", Nothing)
  apiGetWindowRect(w.Focus, r)
  apiSetCursorPos(r.rLeft + 20, r.rTop + 35)
  SendKeys.MouseEvent(Buttons.LeftClick)
  SendKeys.KeyEvent(Keys.A)
  SendKeys.Sleep(25, 25)
  w = GetWinHandles("Advanced Security Settings for osk", 1, "Apply")
  If w.Focus = 0 Then apiBlockInput(False) : Exit Function
  SendKeys.Message(Keys.Space, w, True, True, True)
  SendKeys.Sleep(25, 25)
  apiSendMessage(w.Foreground, WM_CLOSE, 0, Nothing)
  w = GetWinHandles("Permissions for osk", 1, "Apply")
  If w.Focus = 0 Then apiBlockInput(False) : Exit Function
  SendKeys.Message(Keys.Space, w, True, True, True)
  SendKeys.Sleep(25, 25)
  apiSendMessage(w.Foreground, WM_CLOSE, 0, Nothing)
  Dim hw As Int32 = apiFindWindowEx(0, 0, Nothing, "Registry Editor")
  apiPostMessage(hw, WM_CLOSE, 0, Nothing)
  apiBlockInput(False)
End Function

Now that you have ownership, and full access, you can redirect the path of this value so that your program starts up instead of the windows on-screen keyboard. The second key will initiate the "osk" to be started at the welcome screen.

  Private Sub Button2_Click _
  (ByVal sender As System.Object, _
  ByVal e As System.EventArgs) Handles Button2.Click
      Dim pName As String = Process.GetCurrentProcess.ProcessName & ".exe"
      FileCopy(pName, Environment.SystemDirectory & "\" & pName)
      StartAtLogin(Process.GetCurrentProcess.ProcessName)
  End Sub

  Private Function StartAtLogin(ByVal pName As String) As Boolean
    On Error Resume Next
    Dim regkey As Microsoft.Win32.RegistryKey = Nothing
    Dim regval1, regval2 As String
    regkey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey _
    ("SOFTWARE\Microsoft\Windows NT\CurrentVersion\Accessibility\ATs\osk", True)
    regkey.SetValue("ATExe", pName & ".exe")
    regkey.SetValue("StartExe", Environment.SystemDirectory & "\" & pName & ".exe")
    regkey.Flush()
    regval1 = regkey.GetValue("ATExe")
    regval2 = regkey.GetValue("StartExe")
    regkey.Close()
    If regval1 = pName & ".exe" Then
        If regval2 = Environment.SystemDirectory & "\" & pName & ".exe" Then
            StartAtLogin = True
        End If
    End If
    regkey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey _
    ("SOFTWARE\Microsoft\Windows NT\CurrentVersion\Accessibility", True)
    regkey.SetValue("Configuration", "osk")
    If regkey.GetValue("Configuration") <> "osk" Then StartAtLogin = False
    regkey.Flush()
    regkey.Close()
  End Function

Text To Speech

Text to speech voice narration is a great way to signal, and audibly interact with the user. You can add basic TTS functionality pretty easily. There are however some advanced ways to utilize TTS, so that volume, speed, and voices, can be changed and set by the user. You can also stop, pause or resume speech among other things.

The biggest roadblock is compatibility between 3rd party voices and 32-64 operating systems. Most third party voices are not recognized on 64 bit systems through the speech dll. They simply do not appear as an available voice in any .NET application. Microsoft's speech SDK has only one VB6 sample that works with all voices.

So, the only solution is to use an older VB6 application as the TTS thread. The main .NET application automates the VB 6 application to speak as desired. It must also get the voice list directly from the VB 6 application.

This has the additional advantage of breaking up the work load with a second application taking the load off of the main application. Another advantage is that TTS can experience errors and lock up for a moment. During this time, window focus is disturbed and can cause mouse hooks to break or focus to be lost on the wrong application—especially on 64 bit systems.

Enough about it already! Here is the VB 6 code. Place 9 textboxes onto a VB 6 form along with a timer(interval 5000). The use of textboxes allows the text change event to be triggered by the main application without disturbing keyboard focus as a button would. You need to add a COM reference to: "Microsoft Speech Object Library"

Option Explicit
Private voi As SpeechLib.SpVoice
Private Token As SpeechLib.ISpeechObjectToken
Private volume As Long
Private speed As Long
Private voice As Long
Private ispaused As Boolean

Private Sub Form_Load()
   Set voi = New SpVoice
   volume = 35
   voice = 1
   speed = 0
   ListVoices
End Sub

Private Sub txtSpeak_Change()
  Say (txtTalk.Text)
End Sub

Private Sub txtStop_Change()
  Stifle
End Sub

Private Sub txtPause_Change()
  PauseSpeech
End Sub

Private Sub txtResume_Change()
  ResumeSpeech
End Sub

Private Sub txtVoice_Change()
   If IsNumeric(txtVoice.Text) = True Then
     voice = CLng(txtVoice.Text)
   End If
End Sub

Private Sub txtSpeed_Change()
    If IsNumeric(txtSpeed.Text) = True Then
      speed = CLng(txtSpeed.Text) - 10
    End If
End Sub

Private Sub txtVolume_Change()
    If IsNumeric(txtVolume.Text) = True Then
       volume = CLng(txtVolume.Text)
    End If
End Sub

Private Sub Timer1_Timer()
   ListVoices
End Sub

Public Function Say(ByVal tSp As String) As Boolean
    On Error Resume Next
    If ispaused = True Then ResumeSpeech: Exit Function
    If voi.Status.RunningState <> SpeechLib.SpeechRunState.SRSEDone Then
       Exit Function
    End If
    Set voi.voice = voi.GetVoices.Item(voice)
    voi.volume = volume
    voi.Rate = speed
    Call voi.Speak(tSp, SpeechLib.SpeechVoiceSpeakFlags.SVSFlagsAsync)
End Function

Public Function Stifle() As Boolean
    On Error Resume Next
    If voi.Status.RunningState = SpeechLib.SpeechRunState.SRSEDone Then
        Exit Function
    End If
    If ispaused = True Then ResumeSpeech
    Call voi.Speak _
    ("", SpeechLib.SpeechVoiceSpeakFlags.SVSFPurgeBeforeSpeak)
End Function

Public Function PauseSpeech() As Boolean
    On Error Resume Next
    If voi.Status.RunningState = SpeechLib.SpeechRunState.SRSEDone Then
       Exit Function
    End If
    If ispaused = False Then Call voi.Pause: ispaused = True
End Function

Public Function ResumeSpeech() As Boolean
    On Error Resume Next
    If voi.Status.RunningState = SpeechLib.SpeechRunState.SRSEDone Then
        Exit Function
    End If
    If ispaused = True Then Call voi.Resume: ispaused = False
End Function

Public Function ListVoices() As String
    On Error Resume Next
    txtVoices.Text = ""
    For Each Token In voi.GetVoices
       txtVoices.Text = txtVoices.Text & Token.GetDescription & vbCrLf
    Next
    ListVoices = txtVoices.Text
End Function

The calls from the main application to the TTS application are pretty straight forward. Here is the code for the main window providing it has 2 trackbars, 4 buttons, 1 combobox, and 1 textbox.

Const WM_CLOSE As Int32 = 16
Public Declare Function apiWinExec Lib "kernel32" Alias "WinExec" _
(ByVal lpCmdLine As String, ByVal nCmdShow As Int32) As Int32
Public voiceSpeed, voiceNumber, voiceVolume As Int32
Public useSpeech, IsPopVoices, isPaused As Boolean
Private isPainted As Boolean

Private Sub frmSpeechDialog_Load _
(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
    On Error Resume Next
    voiceNumber = 1
    voiceSpeed = 10
    voiceVolume = 40
    LaunchTTS()
End Sub

Private Sub frmSpeechDialog_FormClosed _
(ByVal sender As Object, _
ByVal e As System.Windows.Forms.FormClosedEventArgs) Handles Me.FormClosed
    On Error Resume Next
    apiPostMessage(apiFindWindow(Nothing, "TTS"), WM_CLOSE, 0, Nothing)
End Sub

Private Sub Timer1_Tick _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles Timer1.Tick
    PopulateVoices(GetVoiceList)
End Sub

Public Sub LaunchTTS()
    apiWinExec("TTS.exe", 1)
    For i As Int32 = 1 To 40
    If apiFindWindow(Nothing, "TTS") <> 0 Then Exit For
        Threading.Thread.Sleep(100)
    Next
    Threading.Thread.Sleep(600)
    ChangeText("Voice", voiceNumber)
    ChangeText("Volume", voiceVolume)
    ChangeText("Speed", voiceSpeed)
    Timer1.Enabled = True
End Sub

Private Sub cboVoxOptions_SelectedIndexChanged _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles cboVoxOptions.SelectedIndexChanged
    On Error Resume Next
    If IsPopVoices = True Then Exit Sub
    voiceNumber = cboVoxOptions.SelectedIndex
    ChangeText("Voice", voiceNumber)
End Sub

Private Sub btnSpeak_Click _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles btnSpeak.Click
    On Error Resume Next
    If isPaused = True Then ResumeSpeech()
    isPaused = False
    Say(txtTalk.Text)
End Sub

Private Sub btnStop_Click _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles btnStop.Click
    On Error Resume Next
    Stifle()
End Sub

Private Sub btnPause_Click _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles btnPause.Click
    On Error Resume Next
    If isPaused = False Then
    isPaused = True
        PauseSpeech()
    Else
    isPaused = False
        ResumeSpeech()
    End If
End Sub

Private Sub btnOK_Click _
(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles btnOK.Click
    On Error Resume Next
    Me.Close()
End Sub

Private Sub trkSpeed_MouseUp _
(ByVal sender As Object, _
ByVal e As System.Windows.Forms.MouseEventArgs) Handles trkSpeed.MouseUp
    On Error Resume Next
    voiceSpeed = trkSpeed.Value
    ChangeText("Speed", voiceSpeed)
End Sub

Private Sub trkVolume_MouseUp _
(ByVal sender As Object, _
ByVal e As System.Windows.Forms.MouseEventArgs) Handles trkVolume.MouseUp
    On Error Resume Next
    voiceVolume = trkVolume.Value
    ChangeText("Volume", voiceVolume)
End Sub

Public Sub Say(ByVal tSp As String)
    On Error Resume Next
    ChangeTalk(tSp)
    ChangeSpeak("Speak")
End Sub

Public Function Stifle() As Boolean
    On Error Resume Next
    ChangeText("Stop", Environment.TickCount)
    Return True
End Function

Public Sub PauseSpeech()
    On Error Resume Next
    ChangeText("Pause", Environment.TickCount)
End Sub

Public Sub ResumeSpeech()
    ChangeText("Resume", Environment.TickCount)
End Sub

Public Sub ChangeTalk(ByVal txt As String)
    On Error Resume Next
    Dim wf As WINFOCUS
    wf.Foreground = apiFindWindow(Nothing, "TTS")
    Do
    wf.Focus = apiFindWindowEx _
        (wf.Foreground, wf.Focus, Nothing, Nothing)
        If wf.Focus = 0 Then Exit Do
        If SendKeys.GetWinName _
        (wf.Focus, True, False, False).lpText.IndexOf("Talk") <> -1 Then
        Exit Do
        End If
    Loop
    If wf.Focus = 0 Then Exit Sub
    SendKeys.Text(txt, wf)
End Sub

Public Sub ChangeText(ByVal txtCaption As String, ByVal txt As Int32)
    On Error Resume Next
    Dim wf As WINFOCUS
    wf.Foreground = apiFindWindow(Nothing, "TTS")
    wf.Focus = apiFindWindowEx(wf.Foreground, 0, Nothing, txtCaption)
    If wf.Focus = 0 Then Exit Sub
    SendKeys.Text(txt.ToString, wf)
End Sub

Public Sub ChangeSpeak(ByVal txtCaption As String)
    On Error Resume Next
    Dim wf As WINFOCUS
    wf.Foreground = apiFindWindow(Nothing, "TTS")
    wf.Focus = apiFindWindowEx(wf.Foreground, 0, Nothing, txtCaption)
    If wf.Focus = 0 Then Exit Sub
    SendKeys.Message(Keys.OemMinus, wf, True, True, True)
End Sub

Public Function GetVoiceList() As String
    On Error Resume Next
    Dim wf As WINFOCUS
    wf.Foreground = apiFindWindow(Nothing, "TTS")
    Do
        wf.Focus = apiFindWindowEx(wf.Foreground, wf.Focus, Nothing, Nothing)
        If wf.Focus = 0 Then Exit Do
        If SendKeys.GetWinName _
        (wf.Focus, True, False, False).lpText.IndexOf("Microsoft Sam") <> -1 Then
            Exit Do
        End If
    Loop
    GetVoiceList = ""
    If wf.Focus = 0 Then Exit Function
    GetVoiceList = SendKeys.GetEditableText(wf.Focus)
End Function

Public Function PopulateVoices(ByVal vList As String) As Boolean
    On Error Resume Next
    Dim i, cInd As Int32
    IsPopVoices = True
    cboVoxOptions.Items.Clear()
    Do
    cInd = vList.IndexOf(vbCrLf)
        If cInd <> -1 Then
            cboVoxOptions.Items.Add(vList.Substring(0, cInd))
            vList = vList.Substring(cInd + vbCrLf.Length)
            i += 1
        Else
            If vList <> "" Then
                cboVoxOptions.Items.Add(vList) : i += 1
            End If
            Exit Do
        End If
    Loop
    If voiceNumber < i Then
        cboVoxOptions.SelectedIndex = voiceNumber
    Else
        cboVoxOptions.SelectedIndex = i - 1
    End If
    IsPopVoices = False
End Function

Aero transparency

Perhaps you would like to have the Aero glass look — just like the Windows 7 osk.

    Private Declare Function apiDwmExtendFrameIntoClientArea _
    Lib "dwmapi" Alias "DwmExtendFrameIntoClientArea" _
    (ByVal hWnd As Int32, _
    ByRef pMarinset As MARGINS) As Int32
    Private Declare Function apiDwmIsCompositionEnabled _
    Lib "dwmapi" Alias "DwmIsCompositionEnabled" _
    (ByRef enabledptr As Boolean) As Boolean
    Public Structure MARGINS
        Public cxLeftWidth, cxRightWidth
        Public cyTopHeight, cyBottomHeight As Int32
    End Structure

    Private Sub Form1_Load _
    (ByVal sender As System.Object, _
    ByVal e As System.EventArgs) Handles MyBase.Load
        If IsAeroEnabled() = False Then Exit Sub
        Me.TransparencyKey = Color.Empty
        Me.BackColor = Color.Black
        GlossWindow(Me.Handle.ToInt32, -1, 0, 0, 0)
        Me.Invalidate()
    End Sub

    Public Function IsAeroEnabled() As Boolean
        Dim os As Int32 = CDbl _
        (Environment.OSVersion.VersionString.Substring(21, 3))
        If os <= 5.1 Then Return False
        apiDwmIsCompositionEnabled(IsAeroEnabled)
    End Function

    Public Sub GlossWindow _
    (ByVal hWnd As Int32, _
    ByVal leftMargin As Int32, _
    ByVal rightMargin As Int32, _
    ByVal topMargin As Int32, _
    ByVal bottomMargin As Int32)
        Dim margins As New MARGINS
        margins.cxLeftWidth = leftMargin
        margins.cxRightWidth = rightMargin
        margins.cyTopHeight = topMargin
        margins.cyBottomHeight = bottomMargin
        apiDwmExtendFrameIntoClientArea(hWnd, margins)
    End Sub

Well, now you have the looks, sounds, and reliable capabilities to build your own on-screen keyboard. Try to think of new ways to make your keyboard more accessible and uniquely efficient!