VBA, MS Word и немного персидского языка

Мой друг в совершенстве владеет персидским языком (фарси), но его не устраивает стандартная раскладка клавиатуры при переключении на этот язык. Он попросил ее поменять. Для ранних версий MS Word у него уже был макрос на VBA, который работал следующим образом. Пользователь набирает текст латиницей, выделяет набранный текст и запускает макрос. Тот пробегает по выделенным символам и заменяет их на нужный символ персидского алфавита. Но в новых версиях MS Word данный макрос работать отказывался. И друг попросил меня написать новый.

Для написания макроса была любезно предоставлена таблица символов персидского алфавита, их представления в кодировке Unicode и символы латинского алфавита, которым надо было сделать соответствие. При этом нужно учесть одну особенность персидского языка. Написание буквы зависит от ее положении в тексте. Например: клавиша S сопоставляется букве ﺲ(син).

• ﺲ = U+FEB1, изолировано
• ﺴ = U+FEB3, в начале слова
• ﺳ = U+FEB4, в середине слова
• ﺱ = U+FEB2, в конце слова

Признаться честно, я владею VBA чуть хуже, чем ни как. Поэтому посмотрел как пишет символы фарси сам Word. Оказалось, что, например, ту же букву син (ﺱ) он вне зависимости от позиции вставляет одним и тем же Unicode кодом U+0633 и сам же его правильно отрисовывает в зависимости от позиции. Так же и с остальными символами. По стандарту Unicode здесь срабатывает особый тип модифицирующих символов — селекторы варианта начертания.

С этим знанием остальное уже дело техники: переназначить клавиши. Word все сделает сам.

Option Explicit

' Текущая кодировка клавиатуры и формат расположения параграфа.
Dim localKeyboard As Long
Dim ParagraphFormatAligment As Long

' Процедура для запуска макроса.
Public Sub farsi()
Initialize
End Sub

' Назначение символов фарси клавишам.
'''''''''''''''''''''''''''''''''''''''''''
Public Sub Initialize()

' Сохраняем текущие настройки клавиатуры.
localKeyboard = Application.Keyboard

' Сохраняем смещение параграфа.
ParagraphFormatAligment = Selection.ParagraphFormat.Alignment

' Устанавливаем новую конфигурацию.
Selection.LtrPara
' Раскладка фарси.
Application.Keyboard (1065)
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight

CustomizationContext = NormalTemplate

' Назначаем клавиши свою процедуру.
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyA), _
KeyCategory:=wdKeyCategoryMacro, Command:="a"
KeyBindings.Add KeyCode:=BuildKeyCode(Arg1:=wdKeyShift, Arg2:=wdKeyA), _
KeyCategory:=wdKeyCategoryMacro, Command:="shiftA"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyB), _
KeyCategory:=wdKeyCategoryMacro, Command:="b"
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyP), _
KeyCategory:=wdKeyCategoryMacro, Command:="p"
KeyBindings.Add KeyCategory:=wdKeyCategoryMacro, _
Command:="shiftBackSingleQuote", _
KeyCode:=BuildKeyCode(Arg1:=wdKeyShift, Arg2:=wdKeyBackSingleQuote)

' И так далее для каждой интересующей клавиши.
' ............................................

' Debugging message.
MsgBox KeyBindings.Count & " клавиш назначено в коллекции KeyBindings"

End Sub

' Процедуры, назначаемые клавишам.
Public Sub a()
Selection.TypeText Text:=ChrW(1575)
End Sub
Public Sub shiftA()
Selection.TypeText Text:=ChrW(1570)
End Sub
Public Sub b()
Selection.TypeText Text:=ChrW(1576)
End Sub
Public Sub p()
Selection.TypeText Text:=ChrW(1662)
End Sub
Public Sub shiftBackSingleQuote()
Selection.TypeText Text:=ChrW(1569)
End Sub
' И так далее для каждой интересующей клавиши.
' ............................................

'Возвращаем клавишам их функциональность обратно.
''''''''''''''''''''''''''''''''''''''''''''''''''

' Данную процедуру необходимо вызвать для прекращения работы максроса.
Public Sub UnInitialize()

If Not KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyA)) Is Nothing Then
KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyA)).Clear
End If
If Not KeyBindings.Key(KeyCode:=BuildKeyCode(Arg1:=wdKeyShift, Arg2:=wdKeyA)) Is Nothing Then
KeyBindings.Key(KeyCode:=BuildKeyCode(Arg1:=wdKeyShift, Arg2:=wdKeyA)).Clear
End If
If Not KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyB)) Is Nothing Then
KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyB)).Clear
End If
If Not KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyP)) Is Nothing Then
KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyP)).Clear
End If
If Not KeyBindings.Key(KeyCode:=BuildKeyCode(Arg1:=wdKeyShift, Arg2:=wdKeyBackSingleQuote)) Is Nothing Then
KeyBindings.Key(KeyCode:=BuildKeyCode(Arg1:=wdKeyShift, Arg2:=wdKeyBackSingleQuote)).Clear
End If

' Возвращаем настройки клавиатуры.
Selection.RtlPara
Application.Keyboard (localKeyboard)
Selection.ParagraphFormat.Alignment = ParagraphFormatAligment

' Debuging message
MsgBox KeyBindings.Count & " клавиш назначено в коллекции KeyBindings"

End Sub