Давайте напишем программу для слежения за буфером и его исправлением при копировании русского текста

@HackerVlad · Регистрация: 10.09.2021

Студворк — интернет-сервис помощи студентам

Всем привет!

У меня идея. Давайте напишем программу которая будет нам всем помогать. Которая будет сама менять буфер обмена таким образом чтобы небыло кракозябликов при копировании русского текста в английской раскладке.

Первый мой вопрос. Подскажите функции для слежения за буфером обмена.
Парочку API-функций напишите мне хотябы.

Я хочу получить буфер обмена например в байтовый массив. И сравнить посмотреть что же происходит когда копируется русский текст в английской раскладке и что происходит когда копируется в русской. Чем же отличается буфер. Поэксперементируем и напишем хорошую заплатку.

@HackerVlad · 14.02.2023, 04:21 **[ТС]**

Поэкспериментировал я с буфером обмена Windows. И выяснил я для себя много неожиданного. Разные программы себя ведут по разному, что самое смешное, даже мои самописные две разные программы на VB6 с текстовыми полями при копировании русского текста в буфер ведут себя по разному, так и не понял почему. Смех да и только. В одной программе своей при копировании русского текста и сразу же вставляя уже сразу появлялись вопросики... В другой программе не появлялись.

Есть замечательная утилита программа InsideClipboard, спасибо Dragokas'у, с её помощью смотрел что же происходит в памяти с буфером обмена Windows. Я думаю заплатку написать очень легко по превращению буфера в нормальный русский текст, если там проблемы с русским.

Итак нашёл вот здесь: Работа с буфером обмена много интересного и возьмём этот код за основу получения буфера в уникоде. Хотя этот код очень похож на код с официального сайта майкрософта https://learn.microsoft.com/ru... -clipboard наверное Dragokas его и брал за основу...

Идея слудующая: при копировании русского текста, в английской раскладке, из уникодного текстового элемента менять вопросики на нормальный русский текст в CF_TEXT, значение при этом брать из CF_UNICODETEXT, там будет правильный русский текст. И при копировании русского текста, в английской раскладке, из не уникодного текстового элемента там где лишь ANSI, менять кракозяблики на нормальный русский текст в CF_UNICODETEXT, значение при этом брать из CF_TEXT то есть всё наоборот. Потому что на самом деле русский текст в буфере есть всегда! Нужно его лишь правильно выковырять.

Таким образом можно написать "резидентную" программку которая будет висеть в памяти всегда и менять буфер как надо. Чтобы всегда в буфере был ПРАВИЛЬНЫЙ русский текст! Я такой программки в Интернете почему-то не нашёл. А её написать - легко!

Единственный момент, который меня сейчас парит, это как отловить событие изменение буфера обмена, на ум сейчас приходит лишь проверять буфер обмена по таймеру каждую секунду... С этим надеюсь вы мне поможете и подскажите, ну а пока будет по таймеру фигачить...

Добавлено через 1 час 11 минут
Вот собственно и готовая, мною написанная, заплатка:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
Option Explicit
 
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function MessageBox Lib "user32.dll" Alias "MessageBoxW" (ByVal hwnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32.dll" Alias "lstrcpynW" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60.dll" (src As Any, dst As Any) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
 
Private Const CF_UNICODETEXT    As Long = 13&
Private Const CF_LOCALE         As Long = 16
Private Const GMEM_MOVEABLE     As Long = &H2&
 
Public Function MsgBoxW(Prompt As String, Optional Buttons As Long, Optional Title As String = " ") As Long
    MsgBoxW = MessageBox(0, StrPtr(Prompt), StrPtr(Title), ByVal Buttons)
End Function
 
' Получить буфер в уникоде
Public Function GetClipboardW() As String
    On Error GoTo ErrorHandler
    
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GetClipboardData(CF_UNICODETEXT)
        If hMem Then
            Size = GlobalSize(hMem)
            If Size Then
                txt = Space$(Size \ 2 - 1)
                ptr = GlobalLock(hMem)
                lstrcpyn ByVal StrPtr(txt), ByVal ptr, Size
                GlobalUnlock hMem
                GetClipboardW = txt
            End If
        End If
        CloseClipboard
    End If
    Exit Function
ErrorHandler:
    'Debug.Print "GetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Function
 
' Записать уникодную строку в буфер
Public Sub SetClipboardW(sText As String)
    On Error GoTo ErrorHandler
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GlobalAlloc(GMEM_MOVEABLE, 4)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                GetMem4 &H419, ByVal ptr
                GlobalUnlock hMem
                SetClipboardData CF_LOCALE, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        hMem = GlobalAlloc(GMEM_MOVEABLE, LenB(sText) + 2)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                lstrcpyn ptr, StrPtr(sText), LenB(sText)
                ZeroMemory ByVal (StrPtr(sText) + LenB(sText)), 2&
                GlobalUnlock hMem
                SetClipboardData CF_UNICODETEXT, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        CloseClipboard
    End If
    Exit Sub
ErrorHandler:
    'Debug.Print "SetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Sub
 
Private Function IsCrabsString(str As String) As Boolean
    Dim i As Integer
    
    For i = 192 To 255
        If InStr(1, str, ChrW(i)) > 0 Then
            IsCrabsString = True
            Exit Function ' Для ускорения
        End If
    Next
    
    If InStr(1, str, ChrW(184)) > 0 Then IsCrabsString = True
    If InStr(1, str, ChrW(168)) > 0 Then IsCrabsString = True
End Function
 
' И помогите ещё правильно написать функцию которая определяет что абсолютно все символы в строке являются символами вопроса
Private Function IsQuestionString(str As String) As Boolean
    If str = "?" Or str = "??" Or str = "???" Or str = "????" Or str = "?????" Then
        IsQuestionString = True
        Exit Function ' Для ускорения
    End If
    If Len(str) > 5 Then ' Если 6 вопросительных знаков вподряд и более
        If Mid(str, 1, 6) = "??????" Then
            IsQuestionString = True
            Exit Function ' Для ускорения
        End If
    End If
End Function
 
Private Sub Command1_Click() ' Заплатка исправлялка буфера! По таймеру фигачить что ли? Сильно нагружать будет наверное...
    ' Возьмём символы а-я, А-Я, ёЁ с кодами от 192 до 255 а так же 184 и 168
    
    If Len(GetClipboardW) > 0 Then
        ' Определить содержит ли буфер CF_UNICODETEXT кракозяблики символы а-я, А-Я, ёЁ
        ' Самое сложно это написать функцию определяющею содержит ли строка кракозяблики
        ' Помогите написать эту функцию правильно, сейчас на ум приходит только InStr
        
        If IsCrabsString(GetClipboardW) = True Then ' Буфер содержит кракозяблики
            SetClipboardW Clipboard.GetText ' Исправить буфер (засунуть в уникод правильную строку взятую из не уникода)
            Exit Sub ' Для ускорения
        End If
    End If
    
    If Len(Clipboard.GetText) > 0 Then
        If IsQuestionString(Clipboard.GetText) = True Then
            Clipboard.SetText GetClipboardW ' Исправить буфер
        End If
    End If
End Sub

Добавлено через 5 минут
Вот с таймером, проверяю каждую секунду:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
Option Explicit
 
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function MessageBox Lib "user32.dll" Alias "MessageBoxW" (ByVal hwnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32.dll" Alias "lstrcpynW" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60.dll" (src As Any, dst As Any) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
 
Private Const CF_UNICODETEXT    As Long = 13&
Private Const CF_LOCALE         As Long = 16
Private Const GMEM_MOVEABLE     As Long = &H2&
 
Public Function MsgBoxW(Prompt As String, Optional Buttons As Long, Optional Title As String = " ") As Long
    MsgBoxW = MessageBox(0, StrPtr(Prompt), StrPtr(Title), ByVal Buttons)
End Function
 
' Получить буфер в уникоде
Public Function GetClipboardW() As String
    On Error GoTo ErrorHandler
    
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GetClipboardData(CF_UNICODETEXT)
        If hMem Then
            Size = GlobalSize(hMem)
            If Size Then
                txt = Space$(Size \ 2 - 1)
                ptr = GlobalLock(hMem)
                lstrcpyn ByVal StrPtr(txt), ByVal ptr, Size
                GlobalUnlock hMem
                GetClipboardW = txt
            End If
        End If
        CloseClipboard
    End If
    Exit Function
ErrorHandler:
    'Debug.Print "GetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Function
 
' Записать уникодную строку в буфер
Public Sub SetClipboardW(sText As String)
    On Error GoTo ErrorHandler
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GlobalAlloc(GMEM_MOVEABLE, 4)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                GetMem4 &H419, ByVal ptr
                GlobalUnlock hMem
                SetClipboardData CF_LOCALE, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        hMem = GlobalAlloc(GMEM_MOVEABLE, LenB(sText) + 2)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                lstrcpyn ptr, StrPtr(sText), LenB(sText)
                ZeroMemory ByVal (StrPtr(sText) + LenB(sText)), 2&
                GlobalUnlock hMem
                SetClipboardData CF_UNICODETEXT, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        CloseClipboard
    End If
    Exit Sub
ErrorHandler:
    'Debug.Print "SetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Sub
 
Private Function IsCrabsString(str As String) As Boolean
    Dim i As Integer
    
    For i = 192 To 255
        If InStr(1, str, ChrW(i)) > 0 Then
            IsCrabsString = True
            Exit Function ' Для ускорения
        End If
    Next
    
    If InStr(1, str, ChrW(184)) > 0 Then IsCrabsString = True
    If InStr(1, str, ChrW(168)) > 0 Then IsCrabsString = True
End Function
 
' И помогите ещё правильно написать функцию которая определяет что абсолютно все символы в строке являются символами вопроса
Private Function IsQuestionString(str As String) As Boolean
    If str = "?" Or str = "??" Or str = "???" Or str = "????" Or str = "?????" Then
        IsQuestionString = True
        Exit Function ' Для ускорения
    End If
    If Len(str) > 5 Then ' Если 6 вопросительных знаков вподряд и более
        If Mid(str, 1, 6) = "??????" Then
            IsQuestionString = True
            Exit Function ' Для ускорения
        End If
    End If
End Function
 
Private Sub ClipboardPath()
    ' Возьмём символы а-я, А-Я, ёЁ с кодами от 192 до 255 а так же 184 и 168
    
    If Len(GetClipboardW) > 0 Then
        ' Определить содержит ли буфер CF_UNICODETEXT кракозяблики символы а-я, А-Я, ёЁ
        ' Самое сложно это написать функцию определяющею содержит ли строка кракозяблики
        ' Помогите написать эту функцию правильно, сейчас на ум приходит только InStr
        
        If IsCrabsString(GetClipboardW) = True Then ' Буфер содержит кракозяблики
            SetClipboardW Clipboard.GetText ' Исправить буфер (засунуть в уникод правильную строку взятую из не уникода)
            Exit Sub ' Для ускорения
        End If
    End If
    
    If Len(Clipboard.GetText) > 0 Then
        If IsQuestionString(Clipboard.GetText) = True Then
            Clipboard.SetText GetClipboardW ' Исправить буфер
        End If
    End If
End Sub
 
Private Sub Timer1_Timer()
    ClipboardPath
End Sub

Добавлено через 21 минуту
Программа моя работает на УРА!
Единственный минус - жрёт много системных ресурсов, при копировании огромного количества текста!
Поэкспериментировал и теперь русский текст всегда правильно копируется! Даже в перемешку с китайскими символами. Они конечно будут вопросами но только в ANSI полях.

Один минус - нагружает процессор, если текст в буфере очень большой. Итак проверил через программу Process Hacker 2 (мне нравится больше чем Process Explorer) нагрузка процессора в 0,9 если в буфере 200 КБ, нагрузка 0,6 CPU если в буфере 100 КБ. Если в буфере такая мелочь как даже 5 КБ то нагрузка 0,03. Если в буфере маленький текст, как весь этот текст, то нагрузка 0.01 или вообще никакая. Если в буфере мелочь такая как слова "Программа моя работает на УРА!" то вообще никакой нагрузки. И если буфер пустой то конечно тоже никакой нагрузки.

Добавлено через 35 минут
Есть недоработки. Не всегда будет правильно определять потому как вперемешку с символами вопросов могут идти ещё и английские символы либо спец. символы, но хотябы почищу на пробелы это важная доработка:

На скорую руку, наверное, добавлю ещё код условия если строка будет содержать 6 и более вопросительных знаков вообще хоть где-то в тексте не обязательно в начале

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
' И помогите ещё правильно написать функцию которая определяет что абсолютно все символы в строке являются символами вопроса
Private Function IsQuestionString(str As String) As Boolean
    str = Replace(str, " ", "")
    
    If str = "?" Or str = "??" Or str = "???" Or str = "????" Or str = "?????" Then
        IsQuestionString = True
        Exit Function ' Для ускорения
    End If
    If Len(str) > 5 Then ' Если 6 вопросительных знаков вподряд и более
        If Mid(str, 1, 6) = "??????" Then
            IsQuestionString = True
            Exit Function ' Для ускорения
        End If
    End If
    If InStr(1, str, "??????") Then
        IsQuestionString = True
        Exit Function
    End If
End Function

Добавлено через 14 минут
Кстати иногда ещё может винда заглючить и выскать 521 ошибка мол нельзя прочитать буфер, поэтому на всякий случай надо пропускать ошибки:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Sub ClipboardPath()
    On Error Resume Next
    
    ' Возьмём символы а-я, А-Я, ёЁ с кодами от 192 до 255 а так же 184 и 168
    
    If Len(GetClipboardW) > 0 Then
        ' Определить содержит ли буфер CF_UNICODETEXT кракозяблики символы а-я, А-Я, ёЁ
        ' Самое сложно это написать функцию определяющею содержит ли строка кракозяблики
        ' Помогите написать эту функцию правильно, сейчас на ум приходит только InStr
        
        If IsCrabsString(GetClipboardW) = True Then ' Буфер содержит кракозяблики
            SetClipboardW Clipboard.GetText ' Исправить буфер (засунуть в уникод правильную строку взятую из не уникода)
            Exit Sub ' Для ускорения
        End If
    End If
    
    If Len(Clipboard.GetText) > 0 Then
        If IsQuestionString(Clipboard.GetText) = True Then
            Clipboard.SetText GetClipboardW ' Исправить буфер
        End If
    End If
End Sub

Добавлено через 1 час 15 минут
Придумал улучшения!!! Чтобы не нагружать сильно процессор. Теперь будем выполнять сложные манипуляции, только если буфер изменился. Просто добавил код проверяющий стало ли другое количество символов в буфере. Таким образом теперь, если копировать огромный текст то нагрузка на процессор уменьшился в 10 раз!!!

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

Пожалуйста мой код программы:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
Option Explicit
 
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32.dll" Alias "lstrcpynW" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60.dll" (src As Any, dst As Any) As Long
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
 
Private Const CF_UNICODETEXT    As Long = 13&
Private Const CF_LOCALE         As Long = 16
Private Const GMEM_MOVEABLE     As Long = &H2&
 
Dim LenGetClipboardW As Long
Dim LenClipboardGetText As Long
 
' Получить буфер в уникоде
Public Function GetClipboardW() As String
    On Error GoTo ErrorHandler
    
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GetClipboardData(CF_UNICODETEXT)
        If hMem Then
            Size = GlobalSize(hMem)
            If Size Then
                txt = Space$(Size \ 2 - 1)
                ptr = GlobalLock(hMem)
                lstrcpyn ByVal StrPtr(txt), ByVal ptr, Size
                GlobalUnlock hMem
                GetClipboardW = txt
            End If
        End If
        CloseClipboard
    End If
    Exit Function
ErrorHandler:
    'Debug.Print "GetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Function
 
' Записать уникодную строку в буфер
Public Sub SetClipboardW(sText As String)
    On Error GoTo ErrorHandler
    Dim hMem As Long
    Dim ptr  As Long
    Dim Size As Long
    Dim txt  As String
    
    If OpenClipboard(0) Then
        hMem = GlobalAlloc(GMEM_MOVEABLE, 4)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                GetMem4 &H419, ByVal ptr
                GlobalUnlock hMem
                SetClipboardData CF_LOCALE, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        hMem = GlobalAlloc(GMEM_MOVEABLE, LenB(sText) + 2)
        If hMem <> 0 Then
            ptr = GlobalLock(hMem)
            If ptr <> 0 Then
                lstrcpyn ptr, StrPtr(sText), LenB(sText)
                ZeroMemory ByVal (StrPtr(sText) + LenB(sText)), 2&
                GlobalUnlock hMem
                SetClipboardData CF_UNICODETEXT, hMem
            End If
            'GlobalFree hMem 'do not free!!!
        End If
        CloseClipboard
    End If
    Exit Sub
ErrorHandler:
    'Debug.Print "SetClipboardW" & " - #" & Err.Number & " " & Err.Description & ". LastDllError = " & Err.LastDllError
End Sub
 
Private Function IsCrabsString(str As String) As Boolean
    Dim i As Integer
    
    For i = 192 To 255
        If InStr(1, str, ChrW(i)) > 0 Then
            IsCrabsString = True
            Exit Function ' Для ускорения
        End If
    Next
    
    If InStr(1, str, ChrW(184)) > 0 Then IsCrabsString = True
    If InStr(1, str, ChrW(168)) > 0 Then IsCrabsString = True
End Function
 
' И помогите ещё правильно написать функцию которая определяет что абсолютно все символы в строке являются символами вопроса
Private Function IsQuestionString(str As String) As Boolean
    str = Replace(str, " ", "")
    
    If str = "?" Or str = "??" Or str = "???" Or str = "????" Or str = "?????" Then
        IsQuestionString = True
        Exit Function ' Для ускорения
    End If
    If Len(str) > 5 Then ' Если 6 вопросительных знаков вподряд и более
        If Mid(str, 1, 6) = "??????" Then
            IsQuestionString = True
            Exit Function ' Для ускорения
        End If
    End If
    If InStr(1, str, "??????") Then
        IsQuestionString = True
        Exit Function
    End If
End Function
 
Private Sub ClipboardPath()
    On Error Resume Next
    
    ' Возьмём символы а-я, А-Я, ёЁ с кодами от 192 до 255 а так же 184 и 168
    
    If LenGetClipboardW <> Len(GetClipboardW) Then ' Выполнять код, только если буфер изменился
        LenGetClipboardW = Len(GetClipboardW)
        
        If Len(GetClipboardW) > 0 Then
            ' Определить содержит ли буфер CF_UNICODETEXT кракозяблики символы а-я, А-Я, ёЁ
            ' Самое сложно это написать функцию определяющею содержит ли строка кракозяблики
            ' Помогите написать эту функцию правильно, сейчас на ум приходит только InStr
            
            If IsCrabsString(GetClipboardW) = True Then ' Буфер содержит кракозяблики
                SetClipboardW Clipboard.GetText ' Исправить буфер (засунуть в уникод правильную строку взятую из не уникода)
                Exit Sub ' Для ускорения
            End If
        End If
    End If
    
    If LenClipboardGetText <> Len(Clipboard.GetText) Then ' Выполнять код, только если буфер изменился
        LenClipboardGetText = Len(Clipboard.GetText)
        
        If Len(Clipboard.GetText) > 0 Then
            If IsQuestionString(Clipboard.GetText) = True Then
                Clipboard.SetText GetClipboardW ' Исправить буфер
            End If
        End If
    End If
End Sub
 
Private Sub Form_Load()
    Me.Hide
    App.TaskVisible = False
    
    If App.PrevInstance = True Then
        Unload Me
        End
    End If
End Sub
 
Private Sub Timer1_Timer()
    ClipboardPath
End Sub

Если хотите вносите правки, например, чтобы сделать программу ещё быстрее. Я знаю, что код мой не идеален, но всё же, всё работает как надо)))

Dragokas · 15.02.2023, 20:00

К сожалению, не сразу заметил эту тему.

Код для слежения за буфером выложил здесь.

@HackerVlad · 20.02.2023, 14:03 **[ТС]**

Готовый вариант новой версии программы выложил здесь: Готовые решения и полезные коды на Visual Basic 6.0

Новые блоги и статьи Все статьи Все блоги /
Thinkpad X220 Tablet — это лучший бюджетный ноутбук для учёбы, точка. Programma_Boinc 23.12.2025 Рецензия / Мнение/ Перевод Нашел на реддите интересную статью под названием The Thinkpad X220 Tablet is the best budget school laptop period . Ниже её машинный перевод. Thinkpad X220 Tablet —. . .	PhpStorm 2025.3: WSL Terminal всегда стартует в ~ and_y87 14.12.2025 PhpStorm 2025. 3: WSL Terminal всегда стартует в ~ (home), игнорируя директорию проекта Симптом: После обновления до PhpStorm 2025. 3 встроенный терминал WSL открывается в домашней директории. . .	Как объединить две одинаковые БД Access с разными данными VikBal 11.12.2025 Помогите пожалуйста !! Как объединить 2 одинаковые БД Access с разными данными.	Новый ноутбук volvo 07.12.2025 Всем привет. По скидке в "черную пятницу" взял себе новый ноутбук Lenovo ThinkBook 16 G7 на Амазоне: Ryzen 5 7533HS 64 Gb DDR5 1Tb NVMe 16" Full HD Display Win11 Pro	Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .
От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .	Поиск "дружественных имён" СОМ портов Argus19 22.11.2025 Поиск "дружественных имён" СОМ портов На странице: https:/ / norseev. ru/ 2018/ 01/ 04/ comportlist_windows/ нашёл схожую тему. Там приведён код на С++, который показывает только имена СОМ портов, типа,. . .	Сколько Государство потратило денег на меня, обеспечивая инсулином. Programma_Boinc 20.11.2025 Сколько Государство потратило денег на меня, обеспечивая инсулином. Вот решила сделать интересный приблизительный подсчет, сколько государство потратило на меня денег на покупку инсулинов. . . .	Ломающие изменения в C#.NStar Alpha Etyuhibosecyu 20.11.2025 Уже можно не только тестировать, но и пользоваться C#. NStar - писать оконные приложения, содержащие надписи, кнопки, текстовые поля и даже изображения, например, моя игра "Три в ряд" написана на этом. . .	Мысли в слух kumehtar 18.11.2025 Кстати, совсем недавно имел разговор на тему медитаций с людьми. И обнаружил, что они вообще не понимают что такое медитация и зачем она нужна. Самые базовые вещи. Для них это - когда просто люди. . .

@HackerVlad Испарился 1741 / 637 / 45 Регистрация: 10.09.2021 Сообщений: 2,769

	Давайте напишем программу для слежения за буфером и его исправлением при копировании русского текста 12.02.2023, 16:38. Показов 4346. Ответов 3 Метки нет (Все метки) Всем привет! У меня идея. Давайте напишем программу которая будет нам всем помогать. Которая будет сама менять буфер обмена таким образом чтобы небыло кракозябликов при копировании русского текста в английской раскладке. Первый мой вопрос. Подскажите функции для слежения за буфером обмена. Парочку API-функций напишите мне хотябы. Я хочу получить буфер обмена например в байтовый массив. И сравнить посмотреть что же происходит когда копируется русский текст в английской раскладке и что происходит когда копируется в русской. Чем же отличается буфер. Поэксперементируем и напишем хорошую заплатку. 0

Dragokas 18030 / 7733 / 892 Регистрация: 25.12.2011 Сообщений: 11,502 Записей в блоге: 16
	15.02.2023, 20:00
	К сожалению, не сразу заметил эту тему. Код для слежения за буфером выложил здесь. 0

@HackerVlad Испарился 1741 / 637 / 45 Регистрация: 10.09.2021 Сообщений: 2,769
	20.02.2023, 14:03 [ТС]
	Готовый вариант новой версии программы выложил здесь: Готовые решения и полезные коды на Visual Basic 6.0 0