'---------------------------------------------------------------------------------------
' Author : Щербаков Дмитрий(The_Prist)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose:
'---------------------------------------------------------------------------------------
Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
#Else
    Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
#End If
Dim KLayoutName As String
'отслеживаемые символы (по сути все символы клавиатуры)
Const sAUTOENTER_Symbols$ = "f,dult`;pbqrkvyjghcnea[wxio]sm'.z 0123456789@-_\/"

'ввод перехваченного символа и переход к следующей ячейке
Sub InputLetterToCell(keycode As Integer)
    Dim skey$
    On Error Resume Next
    skey = ChangeLang(Chr(keycode))
    'Диапазон, в который должны вводиться только заглавные буквы
    'если изменяемая ячейка не входит в этот диапазон - буквы остаются в нижнем регистре
    If Not Intersect(ActiveCell, Range("A1:D20")) Is Nothing Then
        skey = UCase(skey)
    End If
    
    If Not ActiveCell.AllowEdit Then
        ActiveCell.Next.Activate
    End If
    ActiveCell.Value = skey
    ActiveCell.Next.Activate
End Sub
'удаление последнего введенного символа клавишей BACKSPACE
Private Sub RemovePrev()
    On Error Resume Next
    If ActiveCell.Value <> "" And ActiveCell.Value <> " " Then
        ActiveCell.Value = ""
        Exit Sub
    End If
    ActiveCell.Previous.Activate
    ActiveCell.Value = ""
End Sub

'процедура определения текущей раскладки и изменение букв с англ на русские
'финт используется, т.к. стандартно onKey "не дружит" с кириллицей при активной английской раскладке
'поэтому у нас для OnKey применяется назначение только для англ.раскладки
Function ChangeLang(skey$) As String
    Const KEYB_RUS$ = "00000419"
    Const KEYB_ENG$ = "00000409"
    Dim CharsRus$, CharsEng$, sChars$
    Dim i&
    Dim IsLangRus As Boolean
    
    CharsRus = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    CharsEng = "F<DULT~:PBQRKVYJGHCNEA{WXIO}SM"">Zf,dult`;pbqrkvyjghcnea[wxio]sm'.z"
    
    KLayoutName = String(9, 0)
    GetKeyboardLayoutName KLayoutName
    
    IsLangRus = (StrComp(KLayoutName, KEYB_RUS, 1) = 0)
    If IsLangRus Then
        sChars = CharsEng
    Else
        sChars = CharsRus
    End If
    i = InStr(sChars, skey)
    If i = 0 Then
        ChangeLang = skey
    Else
        If IsLangRus Then
            sChars = CharsRus
        Else
            sChars = CharsEng
        End If
        ChangeLang = Mid(sChars, i, 1)
    End If
End Function
'включаем отслеживание нажатий клавиатуры
Sub HookKeys(sChars$, FuncName$)
    Dim i&, s$, sx
    On Error Resume Next
    For i = 1 To Len(sChars)
        s = Mid(sChars, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}", "'" & FuncName & """" & Asc(s) & """'"
        Else
            sx = CInt(s) + 96
            Application.OnKey s, "'" & FuncName & """" & Asc(s) & """'"
            Application.OnKey "{" & sx & "}", "'" & FuncName & """" & Asc(s) & """'"
        End If
    Next
End Sub
'отключаем отслеживание нажатий клавиатуры
Sub UnHookKeys(sChars$)
    Dim i&, s$, sx
    On Error Resume Next
    For i = 1 To Len(sChars)
        s = Mid(sChars, i, 1)
        If Not IsNumeric(s) Then
            Application.OnKey "{" & s & "}"
        Else
            sx = CInt(s) + 96
            Application.OnKey s
            Application.OnKey "{" & sx & "}"
        End If
    Next
End Sub

'процедура создания отслеживания нажатия на клавиатуре символов
'для автоматического перехода на следующую ячейку
'   на данный момент вызывается принудительно, но может быть так же вызвана
'   из модуля ЭтаКнига(ThisWorkdbook) в процедуре Workbook_Open
Sub SDV_OneLetterOneCell()
    On Error Resume Next
    HookKeys sAUTOENTER_Symbols, "InputLetterToCell"
    Application.OnKey "{BACKSPACE}", "RemovePrev"
    Application.OnKey "{TAB}"
End Sub
'специальная процедура, запускаемая автоматически перед закрытием книги
'код так же может быть расположен в событийной процедуре модуля ЭтаКнига(ThisWorkdbook) - Workbook_BeforeClose
Private Sub Auto_Close()
    UnHookKeys sAUTOENTER_Symbols
    Application.OnKey "{BACKSPACE}"
End Sub