Список установленных языков и раскладок клавиатуры

Dim objReg, strKeyPath, arrSubKeys, i
Dim objFS, objFile, strList, strLog
Const HKLM = &H80000002
strLog = "Keyboard_Layouts.log"
On Error Resume Next
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
If Err.Number = 0 Then
    strKeyPath = "SYSTEM\CurrentControlSet\Control\Keyboard Layouts"
    objReg.EnumKey HKLM, strKeyPath, arrSubKeys
    If Err.Number = 0 Then
        For i = 0 To UBound(arrSubKeys)
            objReg.GetStringValue HKLM, strKeyPath & "\" & arrSubKeys(i), "Layout Text", strValue
            If Err.Number = 0 Then
                strList = strList & strValue & vbNewLine
            Else
                Err.Clear
            End If
        Next
        If Len(strList) > 0 Then
            Set objFS = CreateObject("Scripting.FileSystemObject")
            strLog = objFS.BuildPath(objFS.GetParentFolderName(WScript.ScriptFullName), strLog)
            Set objFile = objFS.CreateTextFile(strLog, True)
            objFile.Write strList
            objFile.Close
            Set objFile = Nothing
            Set objFS = Nothing
            WScript.Echo "Список создан."
        Else
            WScript.Echo "Список пуст."
        End If
    Else
        WScript.Echo "Ошибка " & Err.Number & vbNewLine & " при выполнении запроса."
        Err.Clear
    End If
Else
    WScript.Echo "Ошибка " & Err.Number & vbNewLine & " при подключении к WMI-пространству."
    Err.Clear
End If
Set objReg = Nothing
WScript.Quit 0

Sub Example()
Dim objReg As Object, strKeyPath As String, arrNames(), arrTypes()
Dim strList As String, strValue As String
Const HKCU = &H80000001
Const HKLM = &H80000002
 
On Error Resume Next
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
If Err.Number = 0 Then
    strKeyPath = "Keyboard Layout\Preload"
    objReg.EnumValues HKCU, strKeyPath, arrNames, arrTypes
    If Err.Number = 0 Then
        ReDim arrTypes(UBound(arrNames))
        For i = 0 To UBound(arrNames)
            objReg.GetStringValue HKCU, strKeyPath, arrNames(i), strValue
            If Err.Number = 0 Then
                strList = strList & strValue & vbNewLine
                arrTypes(i) = strValue
            Else
                Err.Clear
            End If
        Next
        If Len(strList) > 0 Then
            MsgBox strList, vbInformation, "Список кодов раскладок"
            strList = vbNewLine
            strKeyPath = "SYSTEM\CurrentControlSet\Control\Keyboard Layouts"
            For i = 0 To UBound(arrTypes)
                objReg.GetStringValue HKLM, strKeyPath & "\" & arrTypes(i), "Layout Text", strValue
                strList = strList & strValue & " [ " & arrTypes(i) & " ]" & vbNewLine
            Next
            If Len(strList) > 0 Then
                MsgBox strList, vbInformation, "Список  наименований и кодов раскладок"
            Else
                MsgBox "Список наименований и кодов раскладок пуст.", vbExclamation
            End If
        Else
            MsgBox "Список кодов раскладок пуст.", vbExclamation
        End If
    Else
        MsgBox "Ошибка " & Err.Number & vbNewLine & " при выполнении запроса.", vbCritical
        Err.Clear
    End If
Else
    MsgBox "Ошибка " & Err.Number & vbNewLine & " при подключении к WMI-пространству.", vbCritical
    Err.Clear
End If
Set objReg = Nothing
End Sub

    Option Explicit
    Dim objReg, WshShell: Set WshShell = CreateObject("WScript.Shell")
 
    Dim Preloaded()
    Dim Layout
    Dim n
 
    On Error Resume Next
    Do
        n = n + 1
        Layout = WshShell.RegRead("HKCU\Keyboard Layout\Preload\" & n)
        If Err.Number = 0 Then
            ReDim Preserve Preloaded(n - 1)
            Preloaded(n - 1) = Layout
        Else
            Exit Do
        End If
    Loop
    On Error GoTo 0
    
    Dim LangFullName(): ReDim LangFullName(UBound(Preloaded))
    Dim LangShortName(): ReDim LangShortName(UBound(Preloaded))
    
    For n = 0 To UBound(Preloaded)
        LangFullName(n) = WshShell.RegRead("HKLM\SYSTEM\CurrentControlSet\Control\Keyboard Layouts\" & Preloaded(n) & "\Layout Text")
        LangShortName(n) = WshShell.RegRead("HKLM\SYSTEM\CurrentControlSet\Control\Keyboard Layout\DosKeybCodes\" & Preloaded(n))
    Next
    
    Set WshShell = Nothing
    
    MsgBox Join(Preloaded, vbCrLf)
    MsgBox Join(LangFullName, vbCrLf)
    MsgBox Join(LangShortName, vbCrLf)

Sub Procedure_2()
 
    Application.Keyboard 68748313
 
End Sub