VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsKeyboardLayout"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Event EnumKybdLayouts(ByVal LCID As Long)

Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout As Long)
Private Declare Function GetKeyboardLayoutList& Lib "user32" (ByVal nBuff As Long, lpList As Long)
Private Declare Function ActivateKeyboardLayout& Lib "user32" (ByVal hkl As Long, ByVal flags As Long)
Private Declare Function GetKeyboardLayoutNameW Lib "user32" (ByVal pwszKLID As Long) As Long
Private Declare Function GetLocaleInfoW Lib "kernel32" (ByVal Locale As Long, ByVal LCTYPE As Long, ByVal lpData As Long, ByVal cchData As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long
Private Declare Function GetKeyboardState Lib "user32.dll" (ByRef pbKeyState As Byte) As Long
Private Declare Function GetKeyboardType Lib "user32.dll" (ByVal nTypeFlag As Long) As Long

Const KL_NAMELENGTH     As Long = 9
Const KT_TYPE           As Long = 0
Const KT_SUBTYPE        As Long = 1
Const KT_FUNCTIONKEYS   As Long = 2

Const LOCALE_SENGCOUNTRY   As Long = &H1002 '// English name of country
Const LOCALE_SLANGUAGE     As Long = &H2   '// localized name of language
Private buf As String * KL_NAMELENGTH

Public Function GetKybdType() As Long
    GetKybdType = GetKeyboardType(KT_TYPE)
End Function

Public Function GetKybdFunctionKeys() As Long
    GetKybdFunctionKeys = GetKeyboardType(KT_FUNCTIONKEYS)
End Function

Public Function GetKybdSubType() As Long
    GetKybdSubType = GetKeyboardType(KT_SUBTYPE)
End Function

Public Function GetKybdLayoutName() As String
    Dim strName As String

    strName = String(KL_NAMELENGTH, 0)
    GetKeyboardLayoutNameW StrPtr(strName)
    GetKybdLayoutName = StripNull(strName)
End Function

'Purpose: Retrieves current handle to the keyboard layout
Public Function GetKybdLayout() As Long
    Dim lCurrent_HKL As Long
    Dim lActiveWindowHandle As Long
    Dim lActiveWindowThreadId As Long
    Dim lTemp As Long
    
    lActiveWindowHandle = GetForegroundWindow
    lActiveWindowThreadId = GetWindowThreadProcessId(lActiveWindowHandle, lTemp)
    lCurrent_HKL = GetKeyboardLayout(lActiveWindowThreadId)
    GetKybdLayout = lCurrent_HKL And &HFFFF&
End Function


Public Sub EnumKybdLayouts( _
   Optional ByVal NewLayoutLCID As Long = 0, _
   Optional ByVal bEnableCallback As Long = True)
   
   Dim lOriginalLayout  As Long
   Dim lRet             As Long
   Dim i                As Integer

   ReDim lLayouts(50) As Long
   Dim LCID             As Long

   'Save current configuration
   lOriginalLayout = GetKeyboardLayout(0)

   'Get the first 50 supported keyboard layouts (50 is max supported for now)
   lRet = GetKeyboardLayoutList(50, lLayouts(0))
   'Loop through all the keyboard layouts
   For i = 0 To UBound(lLayouts)
      If lLayouts(i) = 0 Then
         Exit For
      End If
      'Activate the keyboard layout and get its name
      lRet = ActivateKeyboardLayout(lLayouts(i), 0)
      lRet = GetKeyboardLayout(0&)
      LCID = LoWord(lRet)
      If NewLayoutLCID = LCID Then
         lOriginalLayout = lRet
      End If
      If bEnableCallback Then
         RaiseEvent EnumKybdLayouts(LCID)
      End If
   Next i

   'Restore current (or requested if available) configuration
   lRet = ActivateKeyboardLayout(lOriginalLayout, 0)

End Sub

Public Function pfGLI(ByVal LCID As Long, ByVal reqInfo As Long) As String
   Dim nRet             As Long
   Dim Buffer           As String

   nRet = GetLocaleInfoW(LCID, reqInfo, StrPtr(Buffer), 0&)

   If nRet Then
      Buffer = Space$(nRet)
      nRet = GetLocaleInfoW(LCID, reqInfo, StrPtr(Buffer), Len(Buffer))
      pfGLI = Left$(Buffer, nRet - 1)
   End If

End Function

Private Function LoWord(wParam As Long) As Integer
   If wParam And &H8000& Then
      LoWord = &H8000& Or (wParam And &H7FFF&)
   Else
      LoWord = wParam And &HFFFF&
   End If
End Function

Private Function StripNull(ByVal StrIn As String) As String
   Dim nul              As Long
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         StripNull = Left$(StrIn, nul - 1)
      Case 1
         StripNull = ""
      Case 0
         StripNull = Trim$(StrIn)
   End Select
End Function
