Страницы: 1
RSS
Исправить крокозяблики в содержимом переменной после копирования текста из VBE
 
Иногда в коде некоторые комментарии хочется выделить заглавными буквами, чтобы выглядело как заголовок. Делаю процедуру преобразования текста в верхний регистр, чтобы повесить её на сочетание клавиш (разумеется, для этого нужно будет сперва переключиться в эксель).
Код
Public Sub UPPERCASE()
Dim ClipBoard As New DataObject
Dim a$, b$
ClipBoard.GetFromClipboard
a = ClipBoard.GetText
b = StrConv(a, vbUpperCase)
ClipBoard.SetText b
ClipBoard.PutInClipboard
End Sub

Когда был скопирован русский текст, но стояла английская раскладка, переменная a получает крокозяблики. Как исправить?
 
ANik, может это поможет
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Поискать на форуме по слову "Кракозяб" не пробовали?
Я сам - дурнее всякого примера! ...
 
Да, должно помочь. Есть ссылка и на этом сайте: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=8&TID=2826&amp...
Но хочется научиться делать программно.
 
Еще вариант использовать API:
Код
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
Private Declare Function LoadKeyboardLayout Lib "user32.dll" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long

Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_INPUTLANGCHANGEREQUEST As Long = &H50
Private Const WM_INPUTLANGCHANGE As Long = &H51

Private Const KBL_EN As String = "00000409" '1033
Private Const KBL_RU As String = "00000419" '1049
Private Const KLF_ACTIVATE  As Long = &H1

Private Const INPUTLANGCHANGE_SYSCHARSET As Long = &H1
Private Const INPUTLANGCHANGE_FORWARD As Long = &H2
Private Const INPUTLANGCHANGE_BACKWARD As Long = &H4

Public Sub UPPERCASE()
    Dim ClipBoard As New DataObject
    Dim a$, b$
    Dim hKBLang As Long
    hKBLang = LoadKeyboardLayout(KBL_RU, KLF_ACTIVATE)
    ' Переключить на русский язык
    Call ActivateKeyboardLayout(hKBLang, 0&)
    SendMessage HWND_BROADCAST, WM_INPUTLANGCHANGEREQUEST, INPUTLANGCHANGE_SYSCHARSET, hKBLang
    ClipBoard.GetFromClipboard
    a = ClipBoard.GetText
    b = StrConv(a, vbUpperCase)
    ClipBoard.SetText b
    ClipBoard.PutInClipboard
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Ммм... да, Дима, так будет даже лучше, поскольку макрос запускается либо по русской, либо по английской клавише, поэтому, переключиться на нужную раскладку будет оптимальное решение.
Спасибо! :-)
 
К сожалению, нет, не помогло  :(
Переключаться на русскую раскладку ж надо до того, как я скопирую текст в буфер обмена...
Так что, буду рад ещё каким-то предложенным решениям...  ;)  
 
Цитата
ANik написал:
надо до того, как я скопирую текст в буфер обмена
Откуда программа узнает, когда Вы решите скопировать? Ищите по форуму - была тема обработки кракозябр, но что-то подсказывает, что не всегда это поможет. Можно еще и локализацию напрямую попробовать указать:
Код
ClipBoard.GetFromClipboard
    a = ClipBoard.GetText
    b = StrConv(a, vbUpperCase, 1049)
    ClipBoard.SetText b
    ClipBoard.PutInClipboard
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Нет, к сожалению b = StrConv(a, vbUpperCase, 1049) тоже не сработало
Помогло это решение (вторая половина).
Код
Public Sub UPPERCASE()
Dim ClipBoard As New DataObject
Dim a$, b$
Dim Arr, i%, sTxt$, sSymb$

ClipBoard.GetFromClipboard
a = ClipBoard.GetText
    
'https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=8&TID=25133&am...
ГЛЮК = a
Arr = Split(Replace(Replace(ГЛЮК, "&#", ";&#"), ";;", ";"), ";")
If UBound(Arr) > LBound(Arr) Then
  On Error Resume Next
  For i = LBound(Arr) To UBound(Arr)
     If Left(Arr(i), 2) = "&#" And Len(Arr(i)) = 5 And IsNumeric(Right(Arr(i), 3)) Then
        Arr(i) = Chr(CInt(Right(Arr(i), 3)))
     End If
  Next
  sTxt = Join(Arr, "")
Else
  For i = 1 To Len(ГЛЮК)
     sSymb = Mid(ГЛЮК, i, 1)
     If AscW(sSymb) > 255 Then
        sTxt = sTxt & sSymb
     Else
        sTxt = sTxt & Chr(AscW(sSymb))
     End If
  Next i
End If

b = StrConv(sTxt, vbUpperCase)
ClipBoard.SetText b
ClipBoard.PutInClipboard
End Sub

Всем спасибо
Страницы: 1
Наверх