Как узнать нужный Font.Charset, зная раскладку клавиатуры?

[arthur2]

Вроде бы, элементаная проблемма, но никак не могу её решить. Нужно, чтобы при переключении раскладки автоматически менялся набор символов текстового поля.

Пока просто использую таблицу соответствий: украинский, белорусский - кирилица, французский, немецкий - западноевропейская, и т.д:

&h0419 - 204
&h0422 - 204
&h0423 - 204
&h040C - 0
&h0408 - 161

и так далее. Но это конечно, не решение, а времянка.

Как по индификатору языка получить нужный Font.Charset ? Ну или хотя бы где взять наиболее полный список таких соответствий?

[arthur2]

Ну что, неужели никто с подобным не сталкивался? Методом глубинного тыка дорылся сегодня сам. Может кому пригодится:

Код: Выделить всё

Option Explicit
Private Const TCI_SRCCODEPAGE = 2&
Private Type FONTSIGNATURE
        fsUsb(4) As Long
        fsCsb(2) As Long
End Type

Private Type CHARSETINFO
        ciCharset As Long
        ciACP As Long
        fs As FONTSIGNATURE
End Type

Private Declare Function TranslateCharsetInfo Lib "gdi32" (ByVal lpSrc As Long, lpcs As CHARSETINFO, ByVal dwFlags As Long) As Long

Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long

Const LOCALE_SLANGUAGE = &H2 ' локализованное название языка
'Public Const LOCALE_SENGLANGUAGE = &H1001 ' английское название языка
'Public Const LOCALE_SABBREVLANGNAME = &H3 ' аббревиатура языка
'Public Const LOCALE_SNATIVELANGNAME = &H4 ' родное название языка
'Public Const LOCALE_ICOUNTRY = &H5 ' код страны
'Public Const LOCALE_SCOUNTRY = &H6 ' локализованное название страны
'Public Const LOCALE_SENGCOUNTRY = &H1002 ' английское название страны
'Public Const LOCALE_SABBREVCTRYNAME = &H7 ' аббревиатура названия страны
'Public Const LOCALE_SNATIVECTRYNAME = &H8 ' родное название страны
'Public Const LOCALE_IDEFAULTCODEPAGE = &HB ' Кодовая страница по умолчанию

Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long



Private Function CharsetFromLayout() As Integer
    Dim CI As CHARSETINFO, tmp As String, ln As Long, cdPg As Long
   
ln = GetKeyboardLayout(0) 'Узнаём раскладку

tmp = Hex(ln)
tmp = Mid$(tmp, Len(tmp) - 3, 4) 'берём информацию только о языке - четыре последних знака

ln = Val("&h" & tmp) 'получили код языка

'   LOCALE_IDEFAULTCODEPAGE = &HB ' даёт какую-то не ту кодовую страницу.

'   &H1004 'даёт то, что надо.  Названия нигде не нашёл,
'   значение получил, перебрав в цикле все числа подряд,
'   пока GetLocaleInfo не выдало  1251 для русского языка

  tmp = Space(128)
  Call GetLocaleInfo(ln, &H1004, tmp, Len(tmp)) ' получаем номер кодовой страницы
  tmp = Split(tmp, vbNullChar)(0)
  cdPg = Val(tmp)
 
    If TranslateCharsetInfo(cdPg, CI, TCI_SRCCODEPAGE) <> 0& Then 'из номера кодовой страницы получаем чарсет
        CharsetFromLayout = CI.ciCharset
    Else
        CharsetFromLayout = -1
    End If
'*****************
'Финтифлюшка:
  tmp = Space(128)
  Call GetLocaleInfo(ln, LOCALE_SLANGUAGE, tmp, Len(tmp))
  Me.Caption = tmp
   
End Function

Private Sub Form_Load()
  textBox1.Font.Name = "Courier New"
  textBox1.Font.Charset = 0
  textBox1.Text = "Всякие разные крякозяблики и прочая киргуда"
  timer1.Interval = 1000
End Sub

Private Sub timer1_Timer()
    Dim ch As Integer
    ch = CharsetFromLayout
    If ch >= 0 Then textBox1.Font.Charset = ch

End Sub




Всем спасибо за неоценимую помощь и участие.