Форум программистов, компьютерный форум CyberForum.ru

Visual Basic

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
25.02.2014, 03:53     Готовые решения и полезные коды на Visual Basic 6.0 #81
Создание GIF-анимации с прозрачным фоном на VB6
Как и обещал для этой темы сделал обратную задачу - создание новой анимации из кадров. Максимальный размер картинок 640х640. В принципе для анимаций без прозрачного фона, а также анимаций с ColorKey цветом прозрачности эта задача очень просто решается с помощью библиотеки GDI+, но у нее, как я выяснил при написании этой тестовой программы, есть недостаток - она не позволяет задать свойство восстановления фона анимации, по крайней мере в MSDN про это ни слова. Это проявляется в виде неприятного наложения кадров друг на друга, когда фон непрозрачен - это не заметно. Для предотвращения этого явления, я решил вручную находить нужные байты и править их "руками". В своем примере я также вычисляю оптимальную палитру с помощью октодерева, поэтому качество получаемых GIF-анимаций получается довольно-таки хорошим. Также имеется возможность настройки каждого кадра (длительность, порог прозрачности) и счетчика повторов. Для отключения прозрачности достаточно в поле Threshold выставить 0, чем выше значение в этом поле, тем больше полупрозрачных пикселей станут полностью прозрачными. Пример я хорошо прокомментировал , особенно в местах, где идет преобразование и сохранение.
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0   Готовые решения и полезные коды на Visual Basic 6.0  
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
25.02.2014, 03:53     Готовые решения и полезные коды на Visual Basic 6.0
Посмотрите здесь:

Visual Basic Visual Basic ^^
Visual Basic 6 и Visual Basic .NET - в чем различия? Visual Basic
Visual Basic Проблема с установкой Visual Studio вообще и Visual Basic
Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net ? Visual Basic
Продам готовые коды и решения на Visual Basic за 400 рублей Visual Basic
Visual Basic Напишите коды в визуал бесик для решения задач
Visual Basic Visual Basic Используя условный оператор if…then, if…then…else или if…then…elseif, разработайте проект для решения следующих заданий:
После регистрации реклама в сообщениях будет скрыта и будут доступны все возможности форума.
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
05.03.2014, 05:40     Готовые решения и полезные коды на Visual Basic 6.0 #82
Пользовательская отрисовка окна
В примере показан способ отрисовки окна (неклиентской области). Поддержка индикатора прогресса в заголовке (в панели задач Win7), анимированная иконка с альфа-каналом, фигурное окно.
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Антихакер32
Заблокирован
06.03.2014, 20:39     Готовые решения и полезные коды на Visual Basic 6.0 #83
Как загрузить на форму не указанный контрол
и использовать его события методы и свойства !

✰ ✰ ✰ пример использования офисного InkEdit
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
11.03.2014, 15:47     Готовые решения и полезные коды на Visual Basic 6.0 #84
Перевод из строки в число и обратно
VB-шные функции для перевода и проверки чисел в строки (и обратно) очень неудобные, в плане того что туда можно много чего написать, и они их "съедят". Можно написать числа в шестнадцатеричной системе или в скобках, в экспоненциальной записи и т.п. С одной стороны это хорошо, но с другой может быть проблемой. Я написал 2 функции которые переводят десятичные целые числа неограниченной размерности из одного представления в другое. Может быть полезно например для отображения (установки) LARGE_INTEGER или любых других больших (сверхбольших) чисел.
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
18.03.2014, 14:15     Готовые решения и полезные коды на Visual Basic 6.0 #85
Получить информацию о используемой памяти процесса
В примере показана возможность получения информации по используемой памяти для каждого запущенного процесса.
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
27.03.2014, 03:32     Готовые решения и полезные коды на Visual Basic 6.0 #86
Круговой визуализатор спектра.
Представляю исходный код и скомпилированную программу графического визуализатора звукового спектра. Звук анализируется через стандартное устройство записи Windows, т.е. можно выбрать микрофон и просматривать спектр с него, либо выбрать стереомикшер и просматривать спектр воспроизводимого звука. В данном визуализаторе имеется возможность регулировки количества отображаемых октав, регулировка прозрачности фона, усиления. Также имеется возможность загрузки палитры из внешних файлов формата PNG в формате 32ARGB, эффекты затухания "размытие" и "горение". Данный визуализатор позволяет просматривать спектр в двух режимах, в виде дуг (колец) и в виде секторов. В первом виде радиальная координата отвечает за частоту по октавам, угловая - между октавами. Гармоники отстоящие от друг друга на октавы, находятся по одну линию, цвет - интенсивность. Во втором режиме, радиальная координата - уровень громкости, цвет - частота, угловая координата - частота (период - 1 октава).
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
PAnT0P
1015 / 538 / 70
Регистрация: 26.03.2012
Сообщений: 980
09.04.2014, 15:37     Готовые решения и полезные коды на Visual Basic 6.0 #87
Класс для работы с реестром
Позволяет работать со следующими типами ключей
REG_SZ
REG_BINARY
REG_DWORD
(в других типах мне не было надобности поэтому не делал)

Также позволяет работать как с x86 так и с x64 ветками из под Win_x64

SetKey - запись ключа в реестр
GetKey - Чтение ключа из реестра
DelKey - удаление ключа из реестра
GetKeys - получение всех ключей из заданной ветки
GetSections - получение всех дочерних веток из заданной ветки
DelSection - удаление ветки со всем содержимым

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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Registry"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
 
Option Explicit
'--------------------------
'Объявить в модуле
'Public Reg As New Registry
'--------------------------
 
Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_NO_MORE_ITEMS As Long = 259
Private Const BUFFER_SIZE As Long = 255
 
'===============================
Public Enum REG_HKEY
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_CURRENT_USER = &H80000001
    HKEY_DYN_DATA = &H80000006
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_USERS = &H80000003
    HKEY_PERF_ROOT = HKEY_LOCAL_MACHINE
End Enum
 
Public Enum REG_TYPE
    REG_SZ = 1&
    REG_EXPAND_SZ = 2&
    REG_BINARY = 3&
    REG_DWORD = 4&
    REG_MULTI_SZ = 7&
End Enum
 
Private Const REG_OPTION_NON_VOLATILE As Long = &H0&
Private Const STANDARD_RIGHTS_ALL As Long = &H1F0000
Private Const SYNCHRONIZE As Long = &H100000
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_READ As Long = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)
Private Const KEY_CREATE_LINK As Long = &H20&
Private Const KEY_CREATE_SUB_KEY As Long = &H4&
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8&
Private Const KEY_NOTIFY As Long = &H10&
Private Const KEY_QUERY_VALUE As Long = &H1&
Private Const KEY_SET_VALUE As Long = &H2&
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_WRITE As Long = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE As Long = (KEY_READ)
Private Const KEY_ALL_ACCESS As Long = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_WOW64_64KEY As Long = &H100&
Private Const KEY_WOW64_32KEY As Long = &H200&
Private Const REG_CREATED_NEW_KEY As Long = &H1
Private Const REG_OPENED_EXISTING_KEY As Long = &H2
 
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As Any) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As REG_HKEY) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
 
Public Function DelKey(ByVal hKey As REG_HKEY, ByVal strPath As String, ByVal strValue As String, Optional ByVal x64 As Boolean = False) As Boolean
    Dim Ret As Long, KEY_WOW  As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    RegOpenKeyEx hKey, strPath, 0, KEY_ALL_ACCESS Or KEY_WOW, Ret
    If Ret <> 0 Then
        RegDeleteValue Ret, strValue
    End If
    RegCloseKey Ret
End Function
 
Public Function DelSection(ByVal hKey As REG_HKEY, ByVal strPath As String, Optional ByVal x64 As Boolean = False) As Boolean
    Dim Ret As Long, KEY_WOW  As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    RegOpenKeyEx hKey, strPath, 0, KEY_ALL_ACCESS Or KEY_WOW, Ret
    If Ret <> 0 Then
        RegDeleteKey hKey, strPath
    End If
    RegCloseKey Ret
End Function
 
'Запись ключа в реестр
Public Function SetKey(ByVal hKey As REG_HKEY, ByVal strPath As String, ByVal strValue As String, ByVal VarData As Variant, ByVal nType As REG_TYPE, Optional ByVal x64 As Boolean = False) As Boolean
    Dim Ret As Long, KEY_WOW  As Long, Result As Long, L As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    If RegCreateKeyEx(hKey, strPath, 0, nType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS Or KEY_WOW, ByVal 0&, Ret, Result) = ERROR_SUCCESS Then
        Select Case nType
          Case REG_SZ
            RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal CStr(VarData), Len(CStr(VarData))
          Case REG_DWORD
            RegSetValueEx Ret, strValue, 0, REG_DWORD, CLng(VarData), 4
          Case REG_BINARY
            RegSetValueEx Ret, strValue, 0, REG_BINARY, CByte(VarData), 4
        End Select
    End If
    RegCloseKey Ret
End Function
 
 
'Чтение ключа из реестра
Public Function GetKey(ByVal hKey As REG_HKEY, ByVal strPath As String, ByVal strValue As String, ByVal defData As Variant, Optional ByVal x64 As Boolean = False)
    Dim Ret As Long, KEY_WOW  As Long
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    RegOpenKeyEx hKey, strPath, 0, KEY_READ Or KEY_WOW, Ret
    GetKey = RegQueryStringValue(Ret, strValue, defData)
    RegCloseKey Ret
End Function
 
Private Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String, ByVal defData)
    Dim lResult As Long, lValueType As Long, lDataBufSize As Long
    lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
    If lResult = 0 Then
        Select Case lValueType
          Case REG_SZ
            Dim DataSz As String
            DataSz = String(lDataBufSize + 1, Chr$(0))
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal DataSz, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = Left$(DataSz, InStr(1, DataSz, Chr$(0)) - 1)
            Else
                RegQueryStringValue = defData
            End If
          Case REG_DWORD
            Dim DataDword As Long
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, DataDword, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = DataDword
            Else
                RegQueryStringValue = defData
            End If
          Case REG_BINARY
            Dim DataBinary As Integer
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, DataBinary, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = DataBinary
            Else
                RegQueryStringValue = defData
            End If
        End Select
    Else
        RegQueryStringValue = defData
    End If
End Function
 
Public Function GetKeys(ByVal hKey As REG_HKEY, ByVal strPath As String, Optional ByVal x64 As Boolean = False) As String()
    Dim Cnt As Long, Ret As Long, nRet As Long, nRetData As Long, KEY_WOW  As Long
    Dim sName As String, sData As String
    Dim Keys() As String
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
'    Ret = BUFFER_SIZE
    'Open a registry key
    If RegOpenKeyEx(hKey, strPath, 0, KEY_READ Or KEY_WOW, Ret) = ERROR_SUCCESS Then
        'initialize
        sName = Space(BUFFER_SIZE)
        sData = Space(BUFFER_SIZE)
        nRet = BUFFER_SIZE
        nRetData = BUFFER_SIZE
        'enumerate the values
        While RegEnumValue(Ret, Cnt, sName, nRet, 0, ByVal 0&, ByVal sData, nRetData) <> ERROR_NO_MORE_ITEMS
            'show data
            If nRet > 0 Then
                ReDim Preserve Keys(Cnt)
                Keys(Cnt) = Left$(sName, nRet)
            End If
            'prepare for next value
            sName = Space(BUFFER_SIZE)
            sData = Space(BUFFER_SIZE)
            nRetData = BUFFER_SIZE
            nRet = BUFFER_SIZE
            Cnt = Cnt + 1
        Wend
        'Close the registry key
        RegCloseKey Ret
    End If
    ReDim Preserve Keys(Cnt)
    GetKeys = Keys
End Function
 
Public Function GetSections(ByVal hKey As REG_HKEY, ByVal strPath As String, Optional ByVal x64 As Boolean = False) As String()
    Dim Cnt As Long, sName As String, sData As String, Ret As Long, RetData As Long, nRet As Long, KEY_WOW  As Long
    Dim Sections() As String
    If x64 Then
        KEY_WOW = KEY_WOW64_64KEY
    Else
        KEY_WOW = KEY_WOW64_32KEY
    End If
    'Open the registry key
    If RegOpenKeyEx(hKey, strPath, 0, KEY_ALL_ACCESS Or KEY_WOW, Ret) = ERROR_SUCCESS Then
        'Create a buffer
        sName = Space(BUFFER_SIZE)
        nRet = BUFFER_SIZE
        'Enumerate the keys
        While RegEnumKeyEx(Ret, Cnt, sName, nRet, ByVal 0&, vbNullString, ByVal 0&, ByVal 0&) <> ERROR_NO_MORE_ITEMS
            'Show the enumerated key
            If nRet > 0 Then
                ReDim Preserve Sections(Cnt)
                Sections(Cnt) = Left$(sName, nRet)
            End If
            'prepare for the next key
            sName = Space(BUFFER_SIZE)
            nRet = BUFFER_SIZE
            Cnt = Cnt + 1
        Wend
        'close the registry key
        RegCloseKey hKey
    End If
    ReDim Preserve Sections(Cnt)
    GetSections = Sections
End Function
Антихакер32
Заблокирован
10.04.2014, 23:56     Готовые решения и полезные коды на Visual Basic 6.0 #88
Очередной раз решил порадовать своими поделками

на этот раз опять компонент ! ..
и примеры использования ...

Блог, куда я разместил новинку будет называться разработка компонентов
из названия понятно что там он будет не один в скором будущем
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Антихакер32
Заблокирован
12.04.2014, 23:20     Готовые решения и полезные коды на Visual Basic 6.0 #89
Класс настраиваемой подсказки ToolTipText

В ходе обсуждений, связанных с подсказками
решил выложить универсальный вариант,
объединил различные настройки в один модуль -
такие как многострочность .. стиль и тд
и перевел некоторые комментарии на понятный язык


✰ ✰ ✰



Ссылка !
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Тестовый проект для CTooltip.cls.rar (5.0 Кб, 68 просмотров)
Антихакер32
Заблокирован
17.04.2014, 18:55     Готовые решения и полезные коды на Visual Basic 6.0 #90
DEMO - проект

в котором тоже есть UserControl, но он извлекает из ресурса
мой контрол Dialogs и сетит все его события методы и свойства
при этом скомпиленный проект можно запустить даже из архива


ниже часть кода что происходит
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
Option Explicit
 
Dim WithEvents Component As VBControlExtender
Event ObjectEvent(Info As EventInfo)
 
 
Public Property Get Obj() As Variant
    'От сюда можно получить доступ к свойствам "Component"
    Set Obj = Component.object
End Property
 
Private Sub UserControl_Initialize()
    'Варианты инициализации
    Set Component = RegSvr32("Dialogs.ocx", "dlgColor")
'    Set Component = RegSvr32("Dialogs.ocx", "dlgOpenSave")
'    Set Component = RegSvr32("Dialogs.ocx", "dlgBrawser")
End Sub
 
Private Function RegSvr32(ByVal Name$, Optional ByVal Class$) As Object
    Const r = "."
    Dim Byt() As Byte, File$, f&, j$()
    j = Split(Trim(Name), r, 2): j(1) = LCase(j(1))
    File = App.Path & "\" & Name
    On Error Resume Next
    f = GetAttr(File) And Not vbDirectory
    If f > 0 And Len(Class) Then
        GoTo FileExist:
    ElseIf Len(Class) Then
        Byt = LoadResData(Name, j(1))
        f = FreeFile
        Open File For Binary As #f
        Put #f, 1, Byt
        Close #f
FileExist:
''        Set Component = Nothing
        For f = 0 To 1 '''' Call Shell("RegSvr32 /s /u " & Name) 'Отмена регистрации
            Select Case LCase(j(1))
            Case "ocx": Licenses.Add j(0) & r & Class
                Set RegSvr32 = Controls.Add(j(0) & r & Class, Class)
            Case "dll": Set RegSvr32 = CreateObject(j(0) & r & Class)
            End Select
            If Err Then
                Call Shell("RegSvr32 /s " & Name) 'Регистрация
                Err.Clear 'Сброс ошибки
            Else: Exit For
            End If
        Next
    End If
End Function
Вложения
Тип файла: rar DEMO Project.rar (387.5 Кб, 33 просмотров)
Тип файла: rar DEMO Картинки.rar (496.2 Кб, 30 просмотров)
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
18.04.2014, 08:54     Готовые решения и полезные коды на Visual Basic 6.0 #91
Работа с указателями в VB6
Антихакер32
Заблокирован
23.04.2014, 21:56     Готовые решения и полезные коды на Visual Basic 6.0 #92
Анализ, синтактический разбор, и получение полной
информации о групповом проекте


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

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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
Option Explicit
'
'   Анализ, синтактический разбор, и получение полной информации о групповом проекте
'   © FelixMacintosh (Антихакер32™)
'
Const r13 = vbCrLf, r59 = ";", r46 = ".", r47 = "/", r34 = """", r58 = ":", r32 = " "
 
Public Enum OperatorFlags '# = Деректива // $ = Декларация // % = Процедура // @ - Блок
    [@Выражение] = 0
    [$Option]
    [$DefType]
    [#Открывающий]
    [#Вариантный]
    [#Закрывающий]
    [#Константа]
    [$Константа]
    [$Открывающий]
    [$Закрывающий]
    [$Declare]
    [$Событие]
    [$Переменная]
    [%Открывающий] 'Процедурный открывающий
    [%Закрывающий]
    [@Открывающий]
    [@Вариантный]
    [@Закрывающий]
    [_Attribute] 'Скрытые параметры которые не отображаются в браузере
    [_Коментарий]
    [_Не_Лэйбл]
End Enum
 
Public Type tOperatorsInfo
    Flag As OperatorFlags
    OperatorLine As String
End Type
 
Public Type tLineInfo
    TabIndex As Long
    Label As String
    Line As String
    Operators() As tOperatorsInfo
    Coment As String
End Type
 
Public Type tModulInfo
    Name As String
    Attribute As String
    TextModule As String
    LinesInfo() As tLineInfo
End Type
 
Public Type tProjectInfo
    Name As String
    Version As String
    Company As String
    Modules() As tModulInfo
End Type
 
Public Type tGlobalInfo
    Projects() As tProjectInfo
End Type
 
Private Type myInfo
    OperatorKeys As Object
    OperatorItems As Object
    fso As Object
    mCDr As String
    bProcPart As Boolean
    IndexRepair As Long
    TabIndex As Long
    Back As Long
End Type
 
Dim t As myInfo, g As tGlobalInfo
Event AddingOperators(NewOperators As Variant, Flag As OperatorFlags)
Private Function OperatorsInfo(List, Line$, Label$) As tOperatorsInfo()
    '
    'Разбивает строку на операторы
    '
    Dim f&, j$(), j1$(), lab& '0 не проверен// 1 проверен // 2 назначен
    Dim mOperatorsInfo() As tOperatorsInfo
    j = List: Label = ""
    
    For f = 0 To UBound(j)
        t.TabIndex = t.TabIndex + t.Back: t.Back = 0 'Сброс
        j(f) = Trim$(j(f))
      
        If lab = 0 Then  'Проверяем лейбл это или нет
            If IsNumeric(j(f)) Then 'Если первый оператор число
                lab = 2: Label = j(f) & IIf(UBound(j) > 0, r58, vbNullString) 'Условия вставки двоеточия
            ElseIf f = 0 And UBound(j) > 0 And InStr(1, j(f), r32) = 0 _
            And InStr(1, j(f), r46) = 0 Then 'Проверяем лейбл это или нет
                lab = IIf(t.OperatorKeys.Exists(j(f)), 1, 2) '[Найден/Не найден] в списке операторов
                If lab = 2 Then Label = j(f) & ":" 'За строковым лейблом следующий оператор
            Else: lab = 1
                j1 = Split(j(f), , 2)
                If IsNumeric(j1(0)) Then 'Проверка если в первом операторе идет число
                    Label = j1(0): j(f) = j1(1)
                End If
            End If
        End If
        If lab <> 2 Then
            ReDim Preserve mOperatorsInfo(Ubn(mOperatorsInfo) + 1)
            With mOperatorsInfo(Ubn(mOperatorsInfo))
                .OperatorLine = j(f)
                .Flag = GetOpFlag(.OperatorLine, Line)
                'Определение для открывающих операторов
                Select Case .Flag
                Case [#Открывающий], [$Открывающий], [%Открывающий], [@Открывающий]
                    t.Back = 1
                Case Else
                    Select Case .Flag
                    Case [#Закрывающий], [$Закрывающий], [%Закрывающий], [@Закрывающий]
                        t.TabIndex = t.TabIndex - 1
                    Case [#Вариантный], [@Вариантный]
                        t.TabIndex = t.TabIndex - 1
                        t.Back = 1
                    End Select
                End Select
            End With
        End If
    Next
    OperatorsInfo = mOperatorsInfo
    
End Function
 
 
 
Public Function GetProject(FileName$) As tGlobalInfo
    '
    'Главная функция класса которая возвращает
    'полную информацию о проекте или группе проектов
    'Арг: Файловый путь с типом VBP // VBG
    '
    Erase g.Projects 'Обнуление прежних данных
    IO_Text (FileName)
    GetProject = g
    On Error GoTo 0
End Function
 
Private Function IO_Text(FileName$, Optional rec&)
    Const FindName = "Name="
    Const FindVersion = "MajorVer=/MinorVer=/RevisionVer="
    Const FindCompany = "VersionCompanyName="
    '//======
    Dim textFile$, j$(), j1$(), f&, f1&, AbsVBP$
    Dim Group() As tProjectInfo
    If rec = 0 Then t.mCDr = CurDir$
    On Error Resume Next '//= Игнорировать ошибки !
    Select Case LCase(t.fso.GetExtensionName(FileName$))
    Case "vbg"
        ChDir t.fso.GetParentFolderName(FileName$)
        textFile = t.fso.OpenTextFile(FileName).ReadAll
        j = Split(textFile, r13)
        For f = 0 To UBound(j)
            Err.Clear: AbsVBP = Trim$(Split(j(f), "=", 2)(1))
            If Err = 0 And t.fso.FileExists(AbsVBP) Then
                IO_Text t.fso.GetAbsolutePathName(AbsVBP), rec + 1
            End If
        Next
    Case "vbp"
        ChDir t.fso.GetParentFolderName(FileName$)
        textFile = t.fso.OpenTextFile(FileName).ReadAll
        j = Split(textFile, r13)
        j1 = Split(FindVersion, r47)
        ReDim Preserve g.Projects(Ubn(g.Projects) + 1)
        For f = 0 To UBound(j)
            Err.Clear: AbsVBP = Trim$(Split(j(f), "=", 2)(1))
            If InStr(1, AbsVBP, r59) Then AbsVBP = Trim$(Split(AbsVBP, r59, 2)(1))
            If t.fso.FileExists(AbsVBP) Then
                IO_Text t.fso.GetAbsolutePathName(AbsVBP), rec + 1
            End If
            With g.Projects(Ubn(g.Projects))
                For f1 = 0 To 2 'Добавление версии
                    If InStr(1, j(f), j1(f1), 1) = 1 Then
                        If f1 Then .Version = .Version & r46
                        .Version = .Version & Trim$(Mid$(j(f), Len(j1(f1)) + 1))
                    End If
                Next
                If InStr(1, j(f), FindName, 1) = 1 Then 'Добавление Name
                    .Name = Trim$(Mid$(j(f), Len(FindName) + 1))
                    .Name = Mid$(.Name, 2, Len(.Name) - 2) 'Без внутренних кавычек
                ElseIf InStr(1, j(f), FindCompany, 1) = 1 Then 'Добавление Company
                    .Company = Trim$(Mid$(j(f), Len(FindCompany) + 1))
                    .Company = Mid$(.Company, 2, Len(.Company) - 2) 'Без внутренних кавычек
                End If
            End With
        Next
    Case "frm", "bas", "cls", "ctl", "dsr", "dob"
        'Создание массива модулей
        If Ubn(g.Projects) < 0 Then ReDim Preserve g.Projects(Ubn(g.Projects) + 1) 'Если стартовым файлом был только модуль
        With g.Projects(Ubn(g.Projects))
            ReDim Preserve .Modules(Ubn(.Modules) + 1)
            .Modules(Ubn(.Modules)) = CreateModule(FileName)
        End With
    End Select
    If rec = 0 Then ChDir t.mCDr
End Function
 
Private Function CreateModule(FileName) As tModulInfo
    Const r = "Attribute VB_Name ="
    Dim AbsText As String, n&, j$(), b As Boolean
    AbsText = t.fso.OpenTextFile(FileName).ReadAll
    On Error Resume Next '//= Игнорировать ошибки !
    With CreateModule
        n = StartVbTx(AbsText)
        .Attribute = Left$(AbsText, n - 1)
        .TextModule = Mid$(AbsText, n)
        If Len(.Attribute) Then
            n = InStr(1, .Attribute, r)
            .Name = Split(Mid$(.Attribute, n), r34, 3)(1)
        End If
        .TextModule = Replace(.TextModule, " _" & r13, r32)
        j = Split(.TextModule, r13)
        .LinesInfo = LinesInfo_(j)
    End With
End Function
 
Private Function LinesInfo_(Lines() As String) As tLineInfo()
    Dim f&, TxLine$, lab&, hstr$, cmnt&, Coment$, Label$
    Dim myLinesInfo() As tLineInfo, b As Boolean
    On Error Resume Next '//= Игнорировать ошибки !
    With t
        .bProcPart = False
        .TabIndex = 0
    End With
    For f = 0 To UBound(Lines)
        TxLine = Trim$(Lines(f)): lab = 0 'Значение определение лейбла для новой строки
        If Len(TxLine) Then
            StringsHide TxLine, hstr 'Скрыть информацию в кавычках
            cmnt = InstrComent(TxLine)
            If cmnt Then Coment = Mid$(TxLine, cmnt): TxLine = Left$(TxLine, cmnt - 1) Else Coment = ""
            TxLine = ReDist(TxLine) 'Сокращение пробелов
            TxLine = Replace(TxLine, r58, vbCr) 'Замена двоеточия
            TxLine = Replace(TxLine, vbCr & r32, vbCr) 'Замена двоеточия и пробела
            StringsRepair TxLine, hstr 'Восстановить информацию в кавычках
            ReDim Preserve myLinesInfo(Ubn(myLinesInfo) + 1)
            With myLinesInfo(Ubn(myLinesInfo))
                .Operators = OperatorsInfo(Split(TxLine, vbCr), TxLine, Label$)
                .Label = Label
                .Coment = Coment
                StringsRepair .Coment, hstr  'Восстановить информацию в кавычках для коментария
                
                b = .Operators(0).Flag = [_Attribute]
                If Len(.Label) Or b Then
                    'Такой вот трюк не устанавливает индекс отступа _
                    если строка начинаеться с лейбла или атрибута
                Else: .TabIndex = t.TabIndex
                End If
                .Line = Lines(f)
            End With
        End If
    Next
    LinesInfo_ = myLinesInfo
End Function
 
Private Function GetOpFlag(Operator As String, Line$) As OperatorFlags
    '
    'Проверяет оператор по отдельным словам и возвращает значение OperatorFlags
    'Арг: Оператор // Строка целиком ! (без коментария)
    '
    Dim f&, j$(), sb$
    j = Split(Operator)
    For f = 0 To UBound(j)
        If f > 2 Then Exit For
        If f Then
            sb = sb & r32
        End If
        sb = sb & j(f)
        If sb = "If" Or sb = "#If" Then
            If StrComp(Right$(Line, 4), "Then", 1) = 0 Then
                GetOpFlag = t.OperatorKeys(sb): Exit For
            End If
        ElseIf t.OperatorKeys.Exists(sb) Then GetOpFlag = t.OperatorKeys(sb)
        End If
    Next
    
    If GetOpFlag > 0 And f > 1 Then
        If LCase(j(1)) = "as" Then
            'Такой глюк может случиться если какойто "умник" _
            в названиях переменных в блоке Type _
            будет использовать ключевые слова _
            например:  Type As String // или Next As Long
            GetOpFlag = [@Выражение] 'Сброс к обычному выражению
        End If
    End If
    If GetOpFlag = [%Открывающий] Then t.bProcPart = True
    
 
End Function
 
 
Private Sub StringsHide(tx$, hstr$)
    '
    'Прячет текст находящийся в кавычках
    '
    Dim f&, f1&, j$()
    j = Split(tx, r34)
    hstr = "": t.IndexRepair = 0
    For f = 1 To UBound(j) Step 2
        For f1 = 1 To Len(j(f))
            hstr = hstr & Mid$(j(f), f1, 1)
            Mid$(j(f), f1, 1) = vbNullChar
        Next
    Next
    tx = Join(j, r34)
End Sub
 
Private Sub StringsRepair(tx$, hstr$)
    '
    'Восстанавливает текст находящийся в кавычках
    '
    Dim n&: n = 1
    With t: Do
            n = InStr(n, tx, vbNullChar)
            If n Then
                .IndexRepair = .IndexRepair + 1
                Mid$(tx, n, 1) = Mid$(hstr, .IndexRepair, 1)
            End If
        Loop While n
    End With
End Sub
 
 
Private Function StartVbTx&(ByVal AbsText$)
    '
    'Возврат позиции начала видимого текста без атрибутов
    '
    Dim f&, I&, j$(), b As Boolean
    StartVbTx = 1
    j = Split(AbsText, r13)
 
    For f = 0 To UBound(j)
        I = InStr(1, j(f), "Attribute VB_", 1)
        If I = 1 And Not b Then
            b = True
        ElseIf I <> 1 And b Then Exit Function
        End If
        StartVbTx = StartVbTx + Len(j(f)) + 2
    Next
    If Not b Then StartVbTx = Sgn(Len(AbsText))
End Function
 
 
Public Sub AddOperators(OperKeys As Variant, item As OperatorFlags)
    '
    'Можно добавить оператор или список операторов под одним значением
    'для последующего синтактичесого анализа
    '
    Dim f&, DicItems As Object: On Error Resume Next '//= Игнорировать ошибки !
    Set DicItems = CreateObject("Scripting.Dictionary"): DicItems.CompareMode = 1
    If IsArray(OperKeys) Then
        For f = 0 To UBound(OperKeys)
            t.OperatorKeys.Add OperKeys(f), item
            DicItems.Add OperKeys(f), item
        Next
        t.OperatorItems.Add item, DicItems
    Else
        t.OperatorKeys.Add OperKeys, item
        DicItems.Add OperKeys, item
        t.OperatorItems.Add item, DicItems
    End If
End Sub
 
Private Sub CreateOperators()
    Dim s1$(), s2$(), s3$(), f1&, f2&, f3&, sb$
    Dim NewOperators As Variant, Flag As OperatorFlags
    If t.OperatorKeys Is Nothing Then
        Set t.OperatorKeys = CreateObject("Scripting.Dictionary"): t.OperatorKeys.CompareMode = 1
        Set t.OperatorItems = CreateObject("Scripting.Dictionary")
    Else: Exit Sub
    End If
    For f1 = 35 To 255
        Select Case f1
        Case 95
        Case 39 To 47, 57 To 63, 91 To 96, 123 To 126
            sb = sb & r13 & "Rem" & Chr(f1)
        End Select
    Next
    AddOperators Split("'" & r13 & "Rem " & sb, r13), [_Коментарий]
    AddOperators "Option", [$Option]
    AddOperators "Attribute", [_Attribute]
    '---------------------
    AddOperators "#If", [#Открывающий]
    AddOperators Split("#Else/#ElseIf", r47), [#Вариантный]
    AddOperators "#End If", [#Закрывающий]
    AddOperators "#Const", [#Константа]
    '-------------------------------------------------------------
    AddOperators Split("Public Const/Global Const", r47), [$Константа]
    AddOperators Split("Event/Public Event", r47), [$Событие]
    AddOperators Split("Public/Global", r47), [$Переменная]
    AddOperators Split("Public Declare/Private Declare/Declare", r47), [$Declare]
        
    s1 = Split("Public /Private /", r47)
    s2 = Split("Enum/Type", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1): For f2 = 0 To UBound(s2)
            sb = sb & r47 & s1(f1) & s2(f2)
    Next: Next
    AddOperators Split(Mid$(sb, 2), r47), [$Открывающий]
    s1 = Split("Enum/Type", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1)
        sb = sb & r47 & "End " & s1(f1)
    Next
    AddOperators Split(Mid$(sb, 2), r47), [$Закрывающий]
    '---------------------------------------------------------------
    s1 = Split("Public /Private /Friend /", r47)
    s2 = Split("Static /", r47)
    s3 = Split("Sub/Function/Property", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1): For f2 = 0 To UBound(s2): For f3 = 0 To UBound(s3)
                sb = sb & r47 & s1(f1) & s2(f2) & s3(f3)
    Next: Next: Next
    AddOperators Split(Mid$(sb, 2), r47), [%Открывающий]
    s1 = Split("Sub/Function/Property", r47)
    sb = "" 'Опустошение сборки
    For f1 = 0 To UBound(s1)
        sb = sb & r47 & "End " & s1(f1)
    Next
    AddOperators Split(Mid$(sb, 2), r47), [%Закрывающий]
    AddOperators Split("Do/If/For/Select Case/With/While", r47), [@Открывающий]
    AddOperators Split("Else/ElseIf/Case", r47), [@Вариантный]
    AddOperators Split("End If/End Select/End With/Loop/Next/Wend", r47), [@Закрывающий]
    AddOperators Split("Close/End/Print/Randomize/Resume/Return/Stop", r47), [_Не_Лэйбл] '''Здесь слова исключающие что это лейбл
    AddOperators Split("DefBool/DefByte/DefInt/DefLng/DefCur/DefSng/DefDbl/DefDec/DefDate/DefStr/DefObj/DefVar", r47), [$DefType]
    RaiseEvent AddingOperators(NewOperators, Flag) 'Событие с возможностью добавления своих
    If Not IsEmpty(NewOperators) Then AddOperators NewOperators, Flag
End Sub
 
Private Sub Class_Initialize()
    Set t.fso = CreateObject("Scripting.FileSystemObject")
    CreateOperators
 
    
End Sub
 
 
Private Function InstrComent&(Line$)
    Dim s$, v, f&, max&, n&
    v = DicOperators([_Коментарий]).Keys
    max = Len(Line)
    For f = 0 To UBound(v): n = InStr(1, Line, v(f), 1)
        If n > 0 And n <= max Then max = n: InstrComent = max
        If n = 1 Then Exit For
    Next
End Function
 
Private Function ReDist$(ByVal tx As String)
    '
    'Reduce the distance
    'Заменить множество пробелов одним // d = сокращаемое значение
    '
    Const d = r32 & r32
    ReDist = Trim$(tx) '//Убрать также передние и задние пробелы
 
    While InStr(1, ReDist, d)
        ReDist = Replace(ReDist, d, r32)
    Wend
End Function
 
 
Private Function DicOperators(item As OperatorFlags) As Object
    Set DicOperators = t.OperatorItems(item)
End Function
 
Private Property Get Ubn&(Arr)
    Ubn = -1: On Error Resume Next: Ubn = UBound(Arr)
End Property
Вот результат если вывести случайный файл модуля
в TextBox для того чтоб убедиться что программа текст понимает правильно !

✰ ✰ ✰ Пользуйтесь
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0   Готовые решения и полезные коды на Visual Basic 6.0   Готовые решения и полезные коды на Visual Basic 6.0  

Готовые решения и полезные коды на Visual Basic 6.0   Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip cProjInfo.zip (5.2 Кб, 26 просмотров)
dev.Free
Заблокирован
26.04.2014, 20:05     Готовые решения и полезные коды на Visual Basic 6.0 #93
Проверка на орфографию средствами Microsoft Word. Ссылка на MSWORD.OLB обязательна. Можно сделать созданием объекта, кому как удобно.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Sub Command1_Click()
    Dim sugList As SpellingSuggestions
    Dim sug As SpellingSuggestion
    Dim strSugList As String
    Dim strWord As String
    strWord = "Летела корова"
    Set sugList = GetSpellingSuggestions(Word:=strWord, SuggestionMode:=wdSpellword)
    If sugList.Count = 0 Then
        MsgBox "Слово без ошибок"
    Else
        For Each sug In sugList
            strSugList = strSugList & vbTab & sug.Name & vbLf
        Next sug
        MsgBox "Варианты замены слова """ & strWord & """:" & vbLf & strSugList
    End If
End Sub
Антихакер32
Заблокирован
28.04.2014, 23:01     Готовые решения и полезные коды на Visual Basic 6.0 #94
Компонент <<Список выбранных>>

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


P.S
Любые обновления и дополнения будут на этой странице
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Test_ListSelected.rar (133.4 Кб, 46 просмотров)
dev.Free
Заблокирован
01.05.2014, 12:12     Готовые решения и полезные коды на Visual Basic 6.0 #95
Немного о ADODB.Recordset:

adLockReadOnly: Набор записей создан только для чтения, не может быть изменен.
adLockPessimistic: Набор записей закрыт для редактирования. То есть во время посылки запроса на редактирование или вставку записи, набор записей закрывается для редактирования другими пользователями. Данный способ применяется при создании локальной базы данных.
adLockOptimistic: Набор записей открыт.
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.05.2014, 02:49     Готовые решения и полезные коды на Visual Basic 6.0 #96
Модифицируем ListBox.

Сделал класс, с помощью которого можно модифицировать отрисовку стандартного списка (рисовать иконки, текст - все что угодно). Он имеет событие Draw, которое вызывается когда нужно отриовать очередной элемент списка. Для работы, нужно установить у списка стиль Checked (флажки), и присвоить данный ListBox свойству clsTrickListBox.ListBox. Также можно изменять высоту элементов и отменять отрисовку.
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Антихакер32
Заблокирован
18.05.2014, 23:02     Готовые решения и полезные коды на Visual Basic 6.0 #97
Интерактивная консоль !

возможность вводить//выводить команды Windows..
прямо из своей единственной формы


Ссылка на пост, где я это породил ...
Антихакер32
Заблокирован
20.05.2014, 20:14     Готовые решения и полезные коды на Visual Basic 6.0 #98
Определение расскладки языка
Форма
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
Option Explicit
'
'© FelixMacintosh (CiberForum.ru)
'Определение текущей расскладки клавиатуры
'
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
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 Const LOCALE_SENGLANGUAGE = &H1001
Dim WithEvents lb As Label, WithEvents tm As Timer
 
Private Sub Form_Load()
    Set lb = Controls.Add("VB.Label", "lb")
    Set tm = Controls.Add("VB.Timer", "tm")
    tm.Interval = 100
    lb.FontSize = 32
    lb.AutoSize = True
    lb.Visible = True
End Sub
 
Public Function GetLanguageInfo(ByVal hwnd As Long) As String
    Dim sReturn As String, nRet As Long
    Dim pID As Long, tId As Long, LCID As Long
    tId = GetWindowThreadProcessId(hwnd, pID)
    LCID = LoWord(GetKeyboardLayout(tId))
    sReturn = String$(128, 0)
    nRet = GetLocaleInfo(LCID, LOCALE_SENGLANGUAGE, sReturn, Len(sReturn))
    If nRet > 0 Then GetLanguageInfo = Left$(sReturn, nRet - 1)
End Function
 
Public Function LoWord(DWORD As Long) As Integer
 
    If DWORD And &H8000& Then
        LoWord = &H8000 Or (DWORD And &H7FFF&)
    Else
        LoWord = DWORD And &HFFFF&
    End If
End Function
 
Private Sub tm_Timer()
    lb.Caption = GetLanguageInfo(FindWindowWild("*", False))
End Sub

Модуль
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
Option Explicit
'
'© FelixMacintosh (CiberForum.ru)
'Определение текущей расскладки клавиатуры
'
Private Declare Function EnumWindows& Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long)
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function IsWindowVisible& Lib "user32" (ByVal hwnd As Long)
Private Declare Function GetParent& Lib "user32" (ByVal hwnd As Long)
Dim sPattern As String, hFind As Long
 
Function EnumWinProc(ByVal hwnd As Long, ByVal lParam As Long) As Long
    Dim k As Long, sName As String
 
    If IsWindowVisible(hwnd) And GetParent(hwnd) = 0 Then
        sName = Space$(128)
        k = GetWindowText(hwnd, sName, 128)
 
        If k > 0 Then
            sName = Left$(sName, k)
            If lParam = 0 Then sName = UCase(sName)
 
            If sName Like sPattern Then
                hFind = hwnd
                EnumWinProc = 0
                Exit Function
            End If
        End If
    End If
    EnumWinProc = 1
End Function
 
Public Function FindWindowWild(sWild As String, Optional bMatchCase As Boolean = True) As Long
    sPattern = sWild
    If Not bMatchCase Then sPattern = UCase(sPattern)
    EnumWindows AddressOf EnumWinProc, bMatchCase
    FindWindowWild = hFind
End Function
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Опредиление языка.rar (2.3 Кб, 27 просмотров)
Антихакер32
Заблокирован
20.05.2014, 20:56     Готовые решения и полезные коды на Visual Basic 6.0 #99
Кстати есть код еще проще

Всего 28 строчек ✰ !

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
Option Explicit
'
'© FelixMacintosh (CiberForum.ru)
'Определение текущей расскладки клавиатуры
'
Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Dim WithEvents lb As Label, WithEvents tm As Timer
Private Sub tm_Timer()
    Dim KeybLayoutName As String
    KeybLayoutName = String(9, 0)
    GetKeyboardLayoutName KeybLayoutName
    KeybLayoutName = Val(KeybLayoutName)
    Select Case KeybLayoutName
    Case 409
        lb.Caption = "Английская"
    Case 419
        lb.Caption = "Русская"
    End Select
End Sub
 
Private Sub Form_Load()
    Set lb = Controls.Add("VB.Label", "lb")
    Set tm = Controls.Add("VB.Timer", "tm")
    tm.Interval = 100
    lb.FontSize = 32
    lb.AutoSize = True
    lb.Visible = True
End Sub

Не по теме:

P.S Сотое, юбилейное готовое решение

Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
20.05.2014, 21:18     Готовые решения и полезные коды на Visual Basic 6.0
Еще ссылки по теме:

Visual Basic Кто пишет программы в Visual Studio 2010 на Visual Basic?
Коды на Visual Basic Visual Basic
Visual Basic Отличия версий Visual Basic 6.0 от Visual Basic 6.5?
Вычисление значений функции двух переменных в Visual Basic - Visual Basic Visual Basic

Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
The trick
Модератор
6928 / 2392 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
20.05.2014, 21:18     Готовые решения и полезные коды на Visual Basic 6.0 #100
Получить текущую раскладку клавиатуры.
Еще проще.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Explicit
 
' Получить раскладку
 
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function VerLanguageName Lib "version.dll" Alias "VerLanguageNameW" (ByVal wLang As Long, ByVal szLang As Long, ByVal nSize As Long) As Long
 
Private Sub Form_Load()
    Dim n As Long, lid As Long, nam As String
    lid = GetKeyboardLayout(0)
    nam = Space(64)
    n = VerLanguageName(lid, StrPtr(nam), 128)
    nam = Left(nam, n)
    MsgBox nam
End Sub
Yandex
Объявления
20.05.2014, 21:18     Готовые решения и полезные коды на Visual Basic 6.0
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Рейтинг@Mail.ru