Форум программистов, компьютерный форум, киберфорум
Наши страницы
Visual Basic
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.98/1070: Рейтинг темы: голосов - 1070, средняя оценка - 4.98
CharlyChaplin
171 / 22 / 2
Регистрация: 28.05.2015
Сообщений: 130
27.02.2017, 13:32 201
Сохранение данных в EXE-файле с использованием хеша SHA-2 (256) и шифрованием Blowfish.

Исправил некоторые недоработки программы из темы.

Описание:

Кликните здесь для просмотра всего текста
Суть: Есть некий интернет-ресурс. Для того, чтобы воспользоваться этим ресурсом, помимо входного пароля, необходимо ввести значения из так называемой SC-карты. (Security Card). Карта представляет из себя таблицу, в которой 50 ячеек. А в каждой ячейке 4-х значное число. Эта карта выдаётся 1 раз на почту. Откуда её сразу рекомендуют распечатать и удалить с почты. Запрос интернет-ресурса звучит так: "введите первые две цифры из ячейки 38 и вторые две цифры из ячейки 18". Номера запрашиваемых ячеек выбираются случайным образом. Всё.

Сама задача лёгкая. Но я, как обычно, заморочился безопасностью хранимых данных... В итоге реализовал таким образом:

Во-первых, я применил разработку The trick о сохранении данных в самом exe-файле программы. Во-вторых, использовал SHA-2 (256) + шифрование по алгоритму Blowfish Брюса Шнайера 16 раундов, т.к. 8 раундов можно взломать подобрав "плохие" ключи, при которых содержимое S и P-блоков будут равны. Алгоритмы SHA-2 (256) и BlowFish реализованы в отдельных модулях. API использовать не стал специально.
В программе имеется одна длинная строка-шаблон, которая обрабатывается и сохраняется. Например:
#Auth^^OldPass...^^NewPass...^^UserName...^^ShotcutParam...#Data...
Данная строка это шаблон. Троеточия заменяются данными от пользователя. Например:
#Auth^^OldPassPass_1^^NewPassPass_2^^UserNameWinUserName^^ShotcutParamCharly#Data3478238945873276...
Конечная секция #Data хранит в себе числа из всех 50-и ячеек. То есть в сумме будет 50*4 = 200 чисел после #Data. Запуск осуществляется с Sub Main.
Такая строка помещается в строковую переменную Converted и "зашивается" в программу. А точнее в ресурсы программы, как писал The trick. Теперь алгоритм работы:

1.) Если при запуске программы Converted пустой, значит это первый запуск, а значит открываем форму и запрашиваем пароль(для открытия программы в будущем), имя пользователя(при другом имени Windows-пользователя программа не запустится) и параметр ярлыка(для удобства открытия программы в режиме чтения при помощи горячих клавиш).
2.) После форма закрывается и выполняются следующие действия, идентифицирующие уникальность данного компьютера:
а.) Определяем логический диск, с которого запущено приложение (Left$(App.Path,3));
б.) Определяем какому физическому диску принадлежит логический диск, с которого запущено приложение;
в.) Передаём номер физического диска процедуре, определяющей ID модели, Serial Number и Firmware number физического жёсткого диска. Эти 3 значения объединяю в одну строку.
Например, мой HDD выглядит так: HGST HTS541010A9E680 JD1009DM2Y9EAK JA0OA7J0.
3.) Берётся хеш SHA-2 (256) из HGSTHTS541010A9E680JD1009DM2Y9EAKJA0OA7J0 и получается 9d70066af4bebb6eb8d30223445ba1f9f9110c45d5c94f15d29f845595f596da. Но из этой строки мы берём первые 56 символов, т.к. Брюс Шнайер говорил, что длина ключа может быть очень большой, но криптоанализ показал, что не стоит превышать значение 448 бит или 56 байт. Поэтому в алгоритме Blowfish сделано ограничение на 56 байт ключа. Так что я обрезаю 64-байтную строку SHA-2 до 56 символов. И 9d70066af4bebb6eb8d30223445ba1f9f9110c45d5c94f15d29f8455 будет являтся ключом к шифрованию нашей строки #Auth^^OldPassPass_1^^NewPassPass_2^^UserNameWinUserName^^ShotcutParamCharly#Data3478238945873276... Другими словами, данный ключ будет уникальным для каждого компьютера. SHA сделано специально, чтобы нельзя было в явном виде посмотреть данные HDD.
После шифрования получается строка в виде Unicode-последовательности, которая преобразуется в длиннющий HEX-вид.
3.) Пользователь заново открывает программу. Либо через ярлык, в свойствах которого написано то, что было введено в поле ShotcutParam. Либо открывает непосредственно сам EXE-файл и вводит пароль. Причём, если он открывает программу через ярлык, то в целях защиты я сделал демо-режим, при котором можно только считывать данные, но посмотреть на таблицу целиком будет нельзя. Можно только задать значения и получить результат. Результат в виде 4-х значного числа помещается в буфер обмена. Если EXE открывается с паролем, то можно и таблицу смотреть, и новый пароль править.
Очень важно то, что если вдруг неправильно введено имя пользователя, то программа просто не запустится, т.к. вся проверка идёт из Sub Main. И форма не появится, пока не будет пройдена проверка. И, если человек не может взломать программу через отладчик, то данные он свои потеряет. Ни я, никто другой не сможет их восстановить. Не знаю, поможет ли дизассемблер с шифрованными данными.
В отладчике я смог увидеть длинную зашифрованную строку, но это ничего не даст, т.к. необходимо будет каким-то образом определить ключ, который невозможно будет подобрать в обозримом будущем, либо напрямую взламывать шифровку, что за более чем 10 лет никому ещё не удалось. А для того, чтобы невозможно было вычислить серийный номер, он захеширован. Конечно расшифровка произойдёт с любым ключом(любым HDD), но текст будет бессмыслицей.

В общем, вот само приложение. Так как модулей много, не стал выкладывать их в это сообщение, а выложу только проект с чистым EXE-файлом. В программе можно легко изменить содержимое сохраняемого Converted на свою структуру. The trick говорил, что можно сохранить в себя всё что угодно. Но я так и не понял как сохранять массивы, а потом считывать массивы, поэтому пришлось работать с одной строкой. Хотя в данной программе было бы удобнее использовать Arr(0) для #Auth, а Arr(1) для #Data.
Программа тестировалась на Win7 x64 и WinXP SP2 x32. На виртуальной машине VmWare работать не будет, т.к. серийник HDD там не определяется. На других ОС не тестировал, т.к. программа написана прежде всего для самого себя, а сижу в Win7 x64.

Если кто знает, как можно достать зашифрованные данные, буду раз, если поделитесь знаниями.


Замечание: в IDE нельзя полностью проверить код, т.к. самозапись не произведётся во временный exe-файл, который создаётся на время отладки средой IDE.
3
Вложения
Тип файла: rar SC.rar (109.2 Кб, 14 просмотров)
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
27.02.2017, 13:32
Ответы с готовыми решениями:

Продам готовые коды и решения на Visual Basic за 400 рублей
душу продаю:cry: Продам коды исходные на VB !!10 лет копил за 400р !!размер...

Коды на Visual Basic
Ребята всем привет,я начел изучать "Visual Basic"! Очень буду благодарен за...

Вывод решения вместо Immediate в textbox (visual basic 6.0)
программа выводит решение в Immediate а я хочу разместить на форме text1 и что...

Вычисление значений функции двух переменных в Visual Basic - Visual Basic
Помогите пожалуйста! В среде VB написать программу вычисления значений функции...

Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net ?
Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net

231
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
01.05.2017, 17:07 202
Калькулятор с функциями vb


2
Dragokas
Эксперт WindowsАвтор FAQ
17009 / 7066 / 856
Регистрация: 25.12.2011
Сообщений: 10,881
Записей в блоге: 16
24.06.2017, 23:43  [ТС] 203
Лучший ответ Сообщение было отмечено Catstail как решение

Решение

Регулярные выражения: обёртка для PCRE2 и VBScript.Regexp

Создано: Polshyn Stanislav (Dragokas) и Jason Peter Brown (jpbro) при поддержке Tanner_H, oumba, DEXWERX, dilettante (vbforums.com)

PCRE2 - это мощная библиотека регулярных выражений, которая работает очень быстро и поддерживает Perl-совместимый синтаксис регулярок, который более шире, чем включённый в VBScript.Regexp.

Вы можете использовать оригинальную обёртку над PCRE2, написанную Jason Peter Brown: https://github.com/jpbro/VbPcre2

Также мною написана прокси-обёртка, основанная на коде от Jason, которая полностью имитирует объектную модель VBScript.Regexp, и при этом позволяет на лету переключаться между движками VBScript.Regexp и PCRE2.

Основная задача прокси обёртки - автопереключение на движок PCRE2, если поврежден файл библиотеки VBScript.dll или её регистрация.
Но она также имеет и другие преимущества:
  • полностью автономная (единый EXE).
  • легко интегрировать в большой проект, в котором уже повсеместно используется код с вызовами "VBScript.Regexp"
  • не требует регистрации и административных полномочий на машине пользователя

Как подключить к своему проекту

* Добавить cRegExp.cls к проекту
* Поместить файл pcre2-16.dll в ту же папку (или альтернативно, эту dll можно поместить в ресурсы с ID 501 - включено в демо-проект).
* Добавить ссылку на IRegexp.tlb - Project => References... (на машине разработчика при первом запуске нужно открыть IDE от имени администратора)
* Использовать как обычную объектную модель "VBScript.Regexp",
только вместо декларации:

Visual Basic
1
2
Dim oRegexp as Object
set oRegexp = CreateObject("VBScript.Regexp")
использовать такую:
Visual Basic
1
2
Dim oRegexp as IRegExp
set oRegexp = New cRegExp
либо такую:
Visual Basic
1
2
3
4
Dim oRegexp as Object
Dim oRegexpProxy as IRegExp
Dim oRegexpProxy = New cRegExp
set oRegexp = oRegexpProxy
Удачи

Демо-проект с фейсом есть в папке "Using". Доп. справка - в файлах Readme.md.
Если найдёте баги, пожалуйста, сообщайте в Issue репозитория GitHub или мне в личку.

Исходный код прокси-обёртки (PCRE2 + VBScript.Regexp): https://github.com/dragokas/VbPcre2
3
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip PCRE2_ProxyWrapper.zip (922.7 Кб, 5 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
17009 / 7066 / 856
Регистрация: 25.12.2011
Сообщений: 10,881
Записей в блоге: 16
02.07.2017, 18:11  [ТС] 204
Класс замера времени работы программы

Удобен, например, если хочется разбить программу на мелкие кусочки (которые могут выполняться по несколько раз) и замерять сколько времени занимает выполнение каждого из них.

Что-то вроде ручного анализа провалов производительности.

Пример использования:

Кликните здесь для просмотра всего текста
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
Option Explicit
 
Dim tim() As cTimer
 
Private Sub Form_Load()
    Dim i As Long
    
    ReDim tim(1) 'для замера двух кусочков кода
    
    Set tim(0) = New cTimer
    Set tim(1) = New cTimer
    
    'начнем замер вот этого кусочка:
    '-------------------------------------- кусочек #1 (начало)
    tim(0).Start
    
    'какая-нибудь "полезная" нагрузка
    For i = 1 To 100000
        DoEvents
    Next
    
    'если нужно приостановить замер
    tim(0).Freeze
    
    MsgBox "Таймер замер"
    
    'возобновляем таймер
    tim(0).Start
    
    'ещё что-нибудь поработает и мы это замерим
    For i = 1 To 100000
        DoEvents
    Next
    '-------------------------------------- кусочек #1 (конец)
    'приостанавливаем таймер
    tim(0).Freeze
    
    'замеряем вторым экземпляром класса какой-то другой кусочек
    '-------------------------------------- кусочек #2 (начало)
    tim(1).Start
    For i = 1 To 100000
        DoEvents
    Next
    tim(1).Freeze
    '-------------------------------------- кусочек #2 (конец)
    
    'вот так можно вывести результаты всех замеров
    Dim s As String
    For i = 0 To UBound(tim)
        s = s & "#" & i & ": " & Format(tim(i).GetTime, "##0.000 sec.") & vbCrLf
    Next
    MsgBox s
    
    'если нужно заново воспользоваться таймером,
    'можно обнулить его
    tim(0).Reset
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'перед завершением программы, уничтожим экземпляры класса
    Dim i As Long
    For i = 0 To UBound(tim)
        Set tim(i) = Nothing
    Next
End Sub


Класс cTimer.cls
Кликните здесь для просмотра всего текста

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
'
' Timer class by Dragokas
'
 
Option Explicit
 
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Any) As Long
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Any) As Long
 
Dim freq As Currency
Dim tim1 As Currency
Dim tim2 As Currency
Dim delta As Currency
Dim bFreeze As Boolean
Dim Idx As Long
 
Private Sub Class_Initialize()
    QueryPerformanceFrequency freq
    bFreeze = True
End Sub
 
Public Sub Reset()
    delta = 0@
End Sub
 
Public Sub Start()
    QueryPerformanceCounter tim1
    bFreeze = False
End Sub
 
Public Sub Freeze()
    If Not bFreeze Then
        QueryPerformanceCounter tim2
        delta = delta + (tim2 - tim1)
        bFreeze = True
    End If
End Sub
 
Public Property Get GetTime() As Currency
    If freq <> 0 Then
        If bFreeze Then
            GetTime = delta / freq
        Else
            QueryPerformanceCounter tim2
            GetTime = (delta + tim2 - tim1) / freq
        End If
    End If
End Property
 
Public Property Get isFreezed() As Boolean
    isFreezed = bFreeze
End Property
 
Public Property Get Index() As Long
    Index = Idx
End Property
 
Public Property Let Index(p_Index As Long)
    Idx = p_Index
End Property


15.09.2017 - код обновлён. Просьба перекачать.
Исправлен случай, когда таймер показывает неверное время, если его остановить прежде, чем запустить.
Добавлено свойство Index для служебных целей, например, для присвоения таймеру порядкового номера и последующей работы с индексом внутри класса.
4
The trick
Модератор
7365 / 2583 / 755
Регистрация: 22.02.2013
Сообщений: 3,799
Записей в блоге: 76
13.07.2017, 19:04 205
Сабклассинг в другом процессе используя DLL.



Этот пример показывает как организовать сабклассинг в другом процессе, используя VB6. В архиве содержится 2 проекта: DLL и EXE. Для того чтобы использовать DLL нужно вызвать функцию Initialize. Функция должна возвратить true, если инициализация прошла успешно. Затем когда нужно установить сабклассинг следует вызвать функцию SetSubclass. Эта функция принимает хендл окна в первом параметре и callback функцию во втором. Эта функция имеет следующий прототип:

Visual Basic
1
2
3
4
5
6
Public Function UserWndProcProto( _
                ByVal hwnd As Long, _
                ByVal uMsg As Long, _
                ByRef wParam As Long, _
                ByRef lParam As Long, _
                ByRef defCall As Boolean) As Long
Параметр defCall определяет стоит ли вызывать функцию по умолчанию или нет. Вы можете изменять параметры wParam, lParam и defCall для изменения поведения окна. Чтобы снять сабклассинг нужно вызвать функцию RemoveSubclass с теми же самыми параметрами которые использовались для установки сабклассинга.

Немного объясню, как это работает.

DLL использует коммуникационное окно для обмена сообщениями. Регистрируется специальный оконный класс и создается экземпляр окна данного класса. Для обмена данными используется проецируемый в память файл, в качестве синхронизирующего элемента - мьютекс. При установке сабклассинга в другом процессе код устанавливает хук WH_CALLWNDPROC для загрузки DLL в целевой процесс. Далее отправляется специальное глобальное сообщение саблассируемому окну которое содержит информацию о сабклассинге. Это сообщение перехватывается функцией CallWndProc в целевом процессе и уже в целевом процессе устанавливается локальный сабклассинг через SetWindowSubclass. Теперь любое сообщение посланное окну будет проходить через нашу функцию WndProc. Теперь нужно передать параметры в наш процесс используя общую память. Для эксклюзивного доступа к памяти захватывается мьютекс, это обеспечивает раздельную обработку каждого события. Когда сообщение обработано в целевом процессе проверяется параметр defCall и при необходимости вызывается предыдущая процедура.

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
' modFunctions.bas  - DLL for global subclassing
' © Anatoly Krivous (The trick), 2016
 
Option Explicit
 
Private Const TRICKWNDCLASS           As String = "TrickGlobalSubclass"         ' // Window class name
Private Const TRICKMUTEX              As String = "TrickGlobalSubclassMutex"    ' // Mutex name
Private Const TRICKMAP                As String = "TrickGlobalSubclassMap"      ' // Mapping name
 
' // This structure describes a message that is passed to subclasser application
Public Type MESSAGESTRUCT
    pWndProc        As Long     ' // Address of user window procedure
    callDef         As Boolean  ' // Determine whether call the default window proc or not
    lResult         As Long     ' // Returned value
    lParam          As Long     ' // Same as in WndProc
    wParam          As Long
    message         As Long
    hwnd            As Long
End Type
 
Private WM_SUBCLASS     As Long     ' // The message identifier for subclassing
                                    ' // Description:
                                    ' // wParam - a hWnd for subclassing
                                    ' // lParam - a hWnd that receives a WM_COPYDATA message
                                    ' // Return value - status
Private WM_UNSUBCLASS   As Long     ' // The message identifier for remove subclassing
Private WM_NEWMESSAGE   As Long     ' // New message available
Private hWndReceiver    As Long     ' // Handle of receiver window
Private isInitialized   As Boolean  ' // Determine whether dll is initialized or not
Private isClassReg      As Boolean  ' // Determine whether window class is registered or not
Private hMutex          As Long     ' // Handle of mutex object
Private pMapping        As Long     ' // Address of shared memory
Private hMap            As Long     ' // Handle of mapping object
Private pWndProcAddress As Long     ' // Address of WndProc procedure
 
' // This is EntryPoint procedure
Public Function DllEntry( _
                ByVal hInstDll As Long, _
                ByVal fdwReason As Long, _
                ByVal lpvReserved As Long) As Long
                
    If fdwReason = DLL_PROCESS_ATTACH Then
        
        ' // Register global communication message
        WM_SUBCLASS = RegisterWindowMessage("WM_SUBCLASS")
        WM_UNSUBCLASS = RegisterWindowMessage("WM_UNSUBCLASS")
        WM_NEWMESSAGE = RegisterWindowMessage("WM_NEWMESSAGE")
        
        ' // Create mutex
        hMutex = CreateMutex(ByVal 0&, 0, TRICKMUTEX)
        ' // Create mapping object
        hMap = CreateFileMapping(INVALID_HANDLE_VALUE, ByVal 0&, PAGE_READWRITE, 0, &H100, TRICKMAP)
        
        If hMap Then
            ' // Map shared memory
            pMapping = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, &H100)
            
        End If
        
        ' // Get address of WndProc
        pWndProcAddress = GetAddr(AddressOf WndProc)
        
        ' // Patch function
        PatchFunc AddressOf UserWndProcProto
 
    ElseIf fdwReason = DLL_PROCESS_DETACH Then
        
        ' // Release resources
        If hWndReceiver Then
        
            DestroyWindow hWndReceiver
            hWndReceiver = 0
            
        End If
        
        If isClassReg Then
        
            UnregisterClass TRICKWNDCLASS, App.hInstance
            isClassReg = False
            
        End If
        
        If hMutex Then
            
            CloseHandle hMutex
            hMutex = 0
            
        End If
        
        If pMapping Then
            
            UnmapViewOfFile ByVal pMapping
            CloseHandle hMap
            
            hMap = 0
            pMapping = 0
            
        End If
        
        isInitialized = False
        
    End If
    
    DllEntry = 1
    
End Function
 
' // You should call this procedure before any subclassing
Public Function Initialize() As Boolean
    Dim cls As WNDCLASSEX
    
    ' // Check DLL initialization
    If WM_SUBCLASS = 0 Or _
       WM_UNSUBCLASS = 0 Or _
       WM_NEWMESSAGE = 0 Or _
       hMutex = 0 Or _
       pMapping = 0 Then Exit Function
    
    cls.cbSize = Len(cls)
    cls.hInstance = App.hInstance
    cls.lpfnWndProc = GetAddr(AddressOf ReceiverProc)
    cls.lpszClassName = StrPtr(TRICKWNDCLASS)
    
    ' // Register class
    If RegisterClassEx(cls) = 0 Then Exit Function
    
    isClassReg = True
    
    ' // Create a receiver window
    hWndReceiver = CreateWindowEx(0, TRICKWNDCLASS, vbNullString, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0&)
    
    If hWndReceiver = 0 Then Exit Function
 
    ' // Set status
    isInitialized = True
    Initialize = True
    
End Function
 
' // This is main function to subclass window
Public Function SetSubclass( _
                ByVal hwnd As Long, _
                ByVal pWndProc As Long) As Boolean
    Dim pid     As Long
    Dim tid     As Long
    Dim hHook   As Long
    
    ' // Check initialization
    If Not isInitialized Then Exit Function
    
    ' // Get thread identifier
    tid = GetWindowThreadProcessId(hwnd, pid)
    
    If tid = App.ThreadID Then
        ' // Local
        If SetWindowSubclass(hwnd, pWndProcAddress, pWndProc, ByVal hWndReceiver) Then
            SetSubclass = True
        End If
    
    Else
    
        ' // Install hook
        hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf CallWndProc, App.hInstance, tid)
       
        If hHook Then
            ' // Send message for subclassing
            ' // This message will be received in the CallWndProc procedure in the needed process
            SendMessage hwnd, WM_SUBCLASS, hWndReceiver, ByVal pWndProc
            ' // Success
            SetSubclass = True
    
            UnhookWindowsHookEx hHook
            
        End If
        
    End If
    
End Function
 
' // This is main function to unsubclass window
Public Function RemoveSubclass( _
                ByVal hwnd As Long, _
                ByVal pWndProc As Long) As Boolean
    
    If Not isInitialized Then Exit Function
    
    If SendMessage(hwnd, WM_UNSUBCLASS, pWndProc, ByVal 0&) Then
        RemoveSubclass = True
    End If
    
End Function
 
' // This is the callback hook procedure
Private Function CallWndProc( _
                 ByVal nCode As Long, _
                 ByVal wParam As Long, _
                 ByRef lParam As CWPSTRUCT) As Long
                
    If nCode = HC_ACTION Then
        
        ' // We can process a message
        Select Case lParam.message
        Case WM_SUBCLASS
            ' // Query for subclassing
            If SetWindowSubclass(lParam.hwnd, pWndProcAddress, lParam.lParam, ByVal lParam.wParam) Then
                ' // Increment library counter
                LoadLibrary App.EXEName
            End If
        End Select
        
    End If
    
    CallWndProc = CallNextHookEx(0, nCode, wParam, lParam)
    
End Function
 
' // This is new window subclass procedure
Private Function WndProc( _
                 ByVal hwnd As Long, _
                 ByVal Msg As Long, _
                 ByVal wParam As Long, _
                 ByVal lParam As Long, _
                 ByVal uIdSubclass As Long, _
                 ByVal dwRefData As Long) As Long
    Dim ret     As Long
    Dim data    As MESSAGESTRUCT
    
    Select Case Msg
    Case WM_SUBCLASS
        ' // Success
        ret = True
        
    Case WM_UNSUBCLASS
        ' // Unsubclass window
        RemoveWindowSubclass hwnd, pWndProcAddress, wParam
 
    Case Else
        ' // Try to capture mutex for exclusive access
        If WaitForSingleObject(hMutex, INFINITE) = WAIT_OBJECT_0 Then
            
            ' // Fill message struct
            data.pWndProc = uIdSubclass
            data.callDef = True
            data.hwnd = hwnd
            data.message = Msg
            data.lParam = lParam
            data.wParam = wParam
            data.lResult = 0
            
            ' // Copy to shared memory
            memcpy ByVal pMapping, data, LenB(data)
            
            ' // Send message to the caller application window
            If SendMessage(dwRefData, WM_NEWMESSAGE, hwnd, ByVal App.ThreadID) Then
            
                ' // Check if need to call the default procedure
                memcpy data, ByVal pMapping, LenB(data)
                
                If data.callDef Then
                    ret = DefSubclassProc(data.hwnd, data.message, data.wParam, data.lParam)
                Else
                    ret = data.lResult
                End If
                
            Else
                ret = DefSubclassProc(hwnd, Msg, wParam, lParam)
            End If
            
            ' // Release mutex
            ReleaseMutex hMutex
            
        Else
            
            ret = DefSubclassProc(hwnd, Msg, wParam, lParam)
            
        End If
        
    End Select
    
    ' // Return value
    WndProc = ret
    
End Function
 
' // This is TrickGlobalSubclass window procedure
Private Function ReceiverProc( _
                 ByVal hwnd As Long, _
                 ByVal uMsg As Long, _
                 ByVal wParam As Long, _
                 ByVal lParam As Long) As Long
    Dim data    As MESSAGESTRUCT
    
    ' // Check window message
    If uMsg = WM_NEWMESSAGE Then
        ' // Mutex already is captured therefore an access to shared data is an atomic
        ' // Get message data form shared memory
        memcpy data, ByVal pMapping, LenB(data)
        ' // Call user window proc by pointer
        data.lResult = UserWndProcProto(data.pWndProc, data.hwnd, data.message, data.wParam, data.lParam, data.callDef)
        ' // Copy parameters
        memcpy ByVal pMapping, data, LenB(data)
        ' // Success
        ReceiverProc = True
    Else
        ReceiverProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    End If
    
End Function
 
Private Function UserWndProcProto( _
                 ByVal pAddress As Long, _
                 ByVal hwnd As Long, _
                 ByVal uMsg As Long, _
                 ByRef wParam As Long, _
                 ByRef lParam As Long, _
                 ByRef defCall As Boolean) As Long
End Function
 
Private Function GetAddr( _
                 ByVal Addr As Long) As Long
    GetAddr = Addr
End Function
4
Вложения
Тип файла: zip GlobalSubclassing.zip (18.4 Кб, 7 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
19.07.2017, 23:19 206
Двигаем картинку за любое место

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

Небольшой код, и вложение с моей картинкой ("0.jpg"), но картинка может быть любая (карта, поле игры, и тд)
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
Option Explicit
 
Dim WithEvents pb As PictureBox
Dim w&, h&, ww&, hh&, sw&, sh&
 
Private Sub Form_Load()
    ChDir App.Path
    Set pb = Controls.Add("vb.PictureBox", "pb"): With pb
        .AutoSize = 1
        .AutoRedraw = 1
        .BorderStyle = 0
        .Picture = LoadPicture("0.jpg")
        .Visible = 1
    End With
    Def sw, Width - ScaleWidth, sh, Height - ScaleHeight
End Sub
 
Private Sub Form_Resize()
    Def ww, -(pb.Width - Width + sw), hh, -(pb.Height - Height + sh): pb.Move 0, 0
End Sub
 
Private Sub pb_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static l&, ll&, t&, tt&
    If Button Then
        Def ll, pb.Left + (X - l), tt, pb.Top + (Y - t)
        If ll <= 0 And ll >= ww Then pb.Left = ll
        If tt <= 0 And tt >= hh Then pb.Top = tt
    Else: Def l, X, t, Y
    End If
End Sub
Sub Def(ParamArray w()): Dim i&: For i = 0 To UBound(w) Step 2: w(i) = w(i + 1): Next: End Sub
1
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Двигаем картинку за любое место.rar (142.9 Кб, 12 просмотров)
CharlyChaplin
171 / 22 / 2
Регистрация: 28.05.2015
Сообщений: 130
31.07.2017, 08:58 207
Таймер на автовыключение/перезагрузку/завершения сеанса с сохранением настроек в самой программе.

Мне настолько понравилось решение The trick о сохранении данных в самом exe, что стал его частенько внедрять в свои программы. Решил поделиться одним из примеров, который работает у меня на рабочем компьютере.

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

Вариант использования:
0.) Помещаем в Автозагрузку(меню Пуск)
1.) Запускаем в первый раз. Настраиваем. Закрываем(настройки сохраняются).
2.) Потом запускаем второй раз(окно уже невидимо) и время контролируется в зависимости от сделанных настроек. Время подошло - программа всплывает. Если нужно, чтобы окно всплыло - нажимаем комбинацию: "Ctrl(любой) + ЛКМ + ПКМ". После настроек её закрываем(она сохраняет) и заново запускаем. При желании можно свернуть в трей пока идёт отсчёт, предварительно настроенных, секунд.
2
Вложения
Тип файла: rar OffTimer.rar (460.4 Кб, 8 просмотров)
Catstail
Модератор
23605 / 11706 / 2046
Регистрация: 12.02.2012
Сообщений: 19,097
13.08.2017, 19:55 208
Создание portable-версий VB-приложений.

Сколько крови лично у меня испортила необходимость инсталлировать любые VB-приложения, которые используют внешние компоненты!..

Для тех, кто не в курсе, объясняю: если приложение использует стандартный диалог, flexgrid, richtextbox, listview, treeview и т.п., то соответствующие OCX-файлы нужно "нести с собой" на компьютер, где устанавливается ваше приложение. Но это, как говорится, полбеды... Хуже то, что эти компоненты (а также разработанные вами OCX-ы) должны быть на целевом компьютере зарегистрированы (добавлены в системный реестр). Дело это не особо хитрое - для каждого компонента нужно вызвать известную утилиту regsvr32. Проблема в том, что вызывать regsvr32 нужно с правами администратора. Это засада!

Между тем, Microsoft давным-давно предоставила механизм запуска COM-компонентов без регистрации. Для этого нужно всего лишь составить файл-манифест и положить его в текущую директорию приложения. Ниже я приведу годную структуру файла манифеста, которую можно использовать в работе.

XML
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
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity name="ИМЯ_ВАШЕГО_ПРИЛОЖЕНИЯ" processorArchitecture="X86" type="win32" 
  version="ВЕРСИЯ_ВАШЕГО_ПРИЛОЖЕНИЯ В ВИДЕ M.M.M.M" />
<description>ОПИСАНИЕ</description>
<file name=".\Com\MSCOMCTL.ocx">
<typelib tlbid="{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" version="2.2" flags="control" helpdir="" />
<comClass clsid="{2C247F23-8591-11D1-B16A-00C0F0283628}" tlbid="{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" threadingModel="Apartment" progid="MSComctlLib.ImageListCtrl.2" description="Microsoft TabStrip Control" />
<comClass clsid="{66833FE6-8583-11D1-B16A-00C0F0283628}" tlbid="{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" threadingModel="Apartment" progid="MSComctlLib.Toolbar.2" description="Microsoft Toolbar Control" />
<comClass clsid="{8E3867A3-8586-11D1-B16A-00C0F0283628}" tlbid="{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" threadingModel="Apartment" progid="MSComctlLib.SBarCtrl.2" description="Microsoft StatusBar Control" />
</file>
<file name=".\Com\RICHTX32.ocx">
<typelib tlbid="{3B7C8863-D78F-101B-B9B5-04021C009402}" version="1.2" flags="control" helpdir="" />
<comClass clsid="{3B7C8860-D78F-101B-B9B5-04021C009402}" tlbid="{3B7C8863-D78F-101B-B9B5-04021C009402}" threadingModel="Apartment" progid="RICHTEXT.RichtextCtrl.1" description="Microsoft Rich Textbox Control 6.0 (SP4)" />
</file>
<file name=".\Com\COMDLG32.ocx">
<typelib tlbid="{F9043C88-F6F2-101A-A3C9-08002B2F49FB}" version="1.2" flags="control" helpdir="" />
<comClass clsid="{F9043C85-F6F2-101A-A3C9-08002B2F49FB}" tlbid="{F9043C88-F6F2-101A-A3C9-08002B2F49FB}" threadingModel="Apartment" progid="MSComDlg.CommonDialog.1" description="Microsoft Common Dialog Control 6.0 (SP6)" />
</file>
<file name=".\Com\MSFLXGRD.OCX">
<typelib tlbid="{5E9E78A0-531B-11CF-91F6-C2863C385E30}" version="1.2" flags="control" helpdir="" />
<comClass clsid="{6262D3A0-531B-11CF-91F6-C2863C385E30}" tlbid="{5E9E78A0-531B-11CF-91F6-C2863C385E30}" threadingModel="Apartment" progid="MSFlexGridLib.MSFlexGrid.1" description="Microsoft Flex Grid (SP6)" />
</file>
<!-- Компоненты собственной разработки -->
<file name=".\Com\CNTASSOLIST.OCX">
<typelib tlbid="{E316DE6E-F751-11DB-82AA-87E48000BA41}" version="1.2" flags="control" helpdir="" />
<comClass clsid="{E316DE70-F751-11DB-82AA-87E48000BA41}" tlbid="{E316DE6E-F751-11DB-82AA-87E48000BA41}" threadingModel="Apartment" progid="cntAssoList.assoList" description="AssoList" />
</file>
<file name=".\Com\CNTOBJLIST.OCX">
<typelib tlbid="{F3B998CF-F751-11DB-82AA-87E48000BA41}" version="1.1" flags="control" helpdir="" />
<comClass clsid="{F3B998D1-F751-11DB-82AA-87E48000BA41}" tlbid="{F3B998CF-F751-11DB-82AA-87E48000BA41}" threadingModel="Apartment" progid="cntObjList.ObjList" description="ObjList" />
</file>
<file name=".\Com\EXTCOMBO.OCX">
<typelib tlbid="{D160BB24-9543-454D-892A-797F5E690438}" version="1.0" flags="control" helpdir="" />
<comClass clsid="{4AB05EE1-F878-4F81-86D8-15BC6737B73E}" tlbid="{D160BB24-9543-454D-892A-797F5E690438}" threadingModel="Apartment" progid="cntExtCombo.extCombo" description="ObjList" />
</file>
</assembly>
Здесь:

ИМЯ_ВАШЕГО_ПРИЛОЖЕНИЯ - это имя исполняемого модуля приложения (без расширения);
ВЕРСИЯ_ВАШЕГО_ПРИЛОЖЕНИЯ В ВИДЕ M.M.M.M - это строка вида "1.13.53.1"
ОПИСАНИЕ - описание (произвольное)

Тэг <file ...> каждого компонента содержит параметр name, который задает путь к соответствующему OCX-файлу. В приведенном выше примере все компоненты располагаются в поддиректории \Com текущей директории.

Далее, у каждого OCX-а должен быть тэг <typelib ...> Его важнейшие параметры tlibid и version. Эти параметры можно взять из vbp-файла проекта (см. параметр Object).

Дальше чуть сложнее. Если некая OCX-библиотека содержит несколько COM-классов (которые использует ваше приложение), то для каждого класса нужно добавить тэг <comClass ...> Важнейшими параметрами этого тэга являются параметры clsid и progid Чтобы их заполнить, придется лезть в реестр системы. Запускаем regedit и ищем, к примеру, MSCOMCTL.ОСХ. Нашли. Теперь, внимание! Верхняя ветвь реестра, описывающая компонент, содержит параметр InprocServer32 (в котором будет найдена строка MSCOMCTL.ОСХ), а также параметр ProgId. Смотрим, что содержится в ProgId. В приведенном выше манифесте первый COM-класс описывает ImageList. В ProgId должна быть строка с соответствующим именем класса. Если имя не то - жмем F3 (продолжаем поиск). После непродолжительных поисков находим класс, у которого в ProgId содержится MSComctlLib.ImageListCtrl.2
Содержимое ProgId заносим в параметр progid, а GUID корня раздела - в параметр clsid.
Параметр tlbid класса делаем равным соответствующему параметру <typelib ...>. Эту работу придется выполнить для всех классов всех библиотек.

Для компонентов собственной разработки задача несколько упрощается, поскольку ProdId собственного компонента искать в реестре не нужно - он и так известен разработчику - Имя_библиотеки.Имя_класса

В приведенном манифесте компоненты собственной разработки выделены комментарием.

И, наконец, самое главное: имя файла-манифеста строится так: берется имя файла-приложения с расширением exe и к нему через точку добавляется "maifest". Таким образом, если ваше приложение называется proga.exe, то манифест должен называться proga.exe.manifest

Удачи!
7
Dragokas
Эксперт WindowsАвтор FAQ
17009 / 7066 / 856
Регистрация: 25.12.2011
Сообщений: 10,881
Записей в блоге: 16
13.08.2017, 20:56  [ТС] 209
Catstail, способ хорош и называется reg-free manifest.

Здесь во вложении есть манифест для большего количества компонентов (создано Elroy с vbforums):

mscomctl.ocx
ComDlg32.OCX
TABCTL32.OCX
RICHTX32.OCX
MSCOMCT2.OCX
COMCT332.OCX

Цитата Сообщение от Catstail
то манифест должен называться proga.exe.manifest
В новых системах этот способ больше не поддерживается.
Нужно подключать как ресурс с типом #24 и ID 1.
6
Вложения
Тип файла: zip AllPurposeDemo.zip (1.18 Мб, 10 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
04.09.2017, 22:02 210
Кнопка с картинкой

Можете перелопатить весь интернет, но такого точно еще не было
Возможность вставить картинку в свою кнопку в форматах ICO GIF BMP
с поддержкой MANIFEST'а
Компонент с единственным модулем.

При заброске (инициализации) создается два слоя первый слой это
на чем проецируется картинка и надпись, и второй на котором собственно кнопка
и через которую передаются события

Код UserControl
Кликните здесь для просмотра всего текста
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
Option Explicit
'
'by the fever.brain 2017 [fever.brain@yandex.ru]
'
Const r = 90, rr = 1.7
Const AddErrVal = 2017
Dim xBut2 As Object
Dim lab As Label
Dim shp As Shape
Dim m_Foreground As Boolean
Dim m_Caption As String
Dim m_Alignment As AlignmentConstants
Dim WithEvents but As CommandButton
'Event Declarations:
Event Click() 'MappingInfo=Command1,But,-1,Click
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Command1,But,-1,MouseUp
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Command1,But,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Command1,But,-1,MouseMove
 
Private Sub But_Click()
    RaiseEvent Click
End Sub
 
Private Sub But_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub
 
Private Sub But_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub
 
Private Sub But_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
 
 
Private Sub UserControl_InitProperties()
    m_Caption = Ambient.DisplayName
    m_Alignment = vbCenter
End Sub
 
 
Private Sub UserControl_Resize()
    Dim PicH&, PicW#, indent&, ii#
    If m_Foreground Then
        but.Move 0, 0, Width, Height
        PicW = xBut2.Icon.Width / rr
        PicH = xBut2.Icon.Height / rr
        Set lab.Font = Font
        lab.Caption = m_Caption
        If PicH < lab.Height Then PicH = lab.Height Else indent = r / 2
        xBut2.Move r, (Height - PicH) / 2, Width, Height
        xBut2.xCls
        Select Case m_Alignment
        Case 0: xBut2.CurrentX = PicW + indent
        Case 1: xBut2.CurrentX = Width - lab.Width - r * 2
        Case 2: xBut2.CurrentX = (Width - lab.Width + PicW - r * 2) / 2
        End Select
        xBut2.CurrentY = (Height - lab.Height) / 2 - xBut2.Top
        xBut2.Caption = m_Caption
    Else
        shp.Move 0, 0, Icon.Width / rr, Icon.Height / rr
    End If
End Sub
 
Private Sub UserControl_Show()
    If m_Foreground Then xBut2.ZOrder 0
    UserControl_Resize
    Refresh
End Sub
 
Private Sub UserControl_Initialize()
    If Err.Number <> AddErrVal Then
        Err.Number = AddErrVal
        Set xBut2 = Controls.Add(App.EXEName & ".xButton", "xBtn" & hWnd): With xBut2
            .Visible = 1
        End With
        Set but = Controls.Add("vb.CommandButton", "but"): With but
            .Visible = 1
        End With
        Set lab = Controls.Add("vb.Label", "lab"): With lab
            .AutoSize = 1
        End With
        m_Foreground = True
    ElseIf Err.Number = AddErrVal Then
        With UserControl
            .Enabled = 0
            .ForeColor = vbMenuText
        End With
        Set shp = Controls.Add("vb.Shape", "shp"): With shp
            .BackColor = SystemColorConstants.vbGrayText
            .BackStyle = 1
            .BorderStyle = 0
            .DrawMode = 15
        End With
        Err.Clear
    End If
    AutoRedraw = True
    BackStyle = vbTransparent
End Sub
 
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Alignment = PropBag.ReadProperty("Alignment", 2)
    BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    Set Font = PropBag.ReadProperty("Font", Ambient.Font)
    Enabled = PropBag.ReadProperty("Enabled", True)
    Set Icon = PropBag.ReadProperty("Icon", Nothing)
    Caption = PropBag.ReadProperty("Caption", "LabCaption")
End Sub
 
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Alignment", m_Alignment, 2)
    Call PropBag.WriteProperty("BackColor", but.BackColor, &H8000000F)
    Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Icon", Icon, Nothing)
    Call PropBag.WriteProperty("Caption", m_Caption, "LabCaption")
End Sub
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property
 
Public Property Let Enabled(ByVal New_Enabled As Boolean)
    If m_Foreground Then
        but.Enabled = New_Enabled
        xBut2.ForeColor = IIf(New_Enabled, SystemColorConstants.vbMenuText, SystemColorConstants.vbGrayText)
        xBut2.Enabled = New_Enabled
        UserControl.Enabled() = New_Enabled
        UserControl_Resize
    Else
        shp.Visible = IIf(New_Enabled, 0, 1)
        shp.ZOrder IIf(New_Enabled, 1, 0)
        UserControl.MaskPicture = UserControl.Image
    End If
    PropertyChanged "Enabled"
End Property
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Label1,Label1,-1,Alignment
Public Property Get Alignment() As AlignmentConstants
    Alignment = m_Alignment
End Property
 
Public Property Let Alignment(ByVal New_Alignment As AlignmentConstants)
    m_Alignment = New_Alignment
    UserControl_Resize
    PropertyChanged "Alignment"
End Property
 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Command1,but,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
    BackColor = but.BackColor
End Property
 
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    but.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property
 
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = UserControl.ForeColor
End Property
 
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    UserControl.ForeColor() = New_ForeColor
    If m_Foreground Then
        xBut2.ForeColor = New_ForeColor
        UserControl_Resize
    End If
    PropertyChanged "ForeColor"
End Property
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Command1,UserControl,-1,Font
Public Property Get Font() As Font
    Set Font = UserControl.Font
End Property
 
Public Property Set Font(ByVal New_Font As Font)
    If m_Foreground Then
        Set xBut2.Font = New_Font
        UserControl_Resize
    End If
    Set UserControl.Font = New_Font
    PropertyChanged "Font"
End Property
 
'[CurrentX]=============================
Public Property Get CurrentX() As Single: CurrentX = UserControl.CurrentX: End Property
Public Property Let CurrentX(ByVal New_CurrentX As Single): UserControl.CurrentX() = New_CurrentX: End Property
 
'[CurrentY]=============================
Public Property Get CurrentY() As Single: CurrentY = UserControl.CurrentY: End Property
Public Property Let CurrentY(ByVal New_CurrentY As Single): UserControl.CurrentY() = New_CurrentY: End Property
    
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Icon
Public Property Get Icon() As Picture
    Set Icon = UserControl.Picture
End Property
 
Public Property Set Icon(ByVal New_Icon As Picture)
    If m_Foreground Then
        xBut2.Icon = New_Icon
        UserControl_Resize
        PropertyChanged "Icon"
    End If
    Set UserControl.Picture = New_Icon
    UserControl.MaskPicture = UserControl.Image
End Property
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=Label1,Lab,-1,Caption
Public Property Get Caption() As String
    Caption = m_Caption
End Property
 
Public Property Let Caption(ByVal New_Caption As String)
    If m_Foreground Then
        m_Caption = New_Caption
        UserControl_Resize
        PropertyChanged "Caption"
    Else
        Print New_Caption
        UserControl.MaskPicture = UserControl.Image
    End If
End Property
 
Public Sub xCls()
    Cls
End Sub
 
Private Sub UserControl_Terminate()
    Dim v
    On Error Resume Next: For Each v In Controls: Controls.Remove v: Next
End Sub


Исходники:
xButton.rar

На картинке проект с добавленным контролом xButton
2
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Изображения
 
Dragokas
Эксперт WindowsАвтор FAQ
17009 / 7066 / 856
Регистрация: 25.12.2011
Сообщений: 10,881
Записей в блоге: 16
19.09.2017, 01:29  [ТС] 211
Назначение иконки пункту меню с привязкой к его имени

Автор: Dragokas

В стандартном редакторе меню нет возможности назначать иконку пункту меню.
Этот модуль восполняет пробел.

Чтобы назначить иконку, вызовите функцию SetMenuIconByName, указав хендл формы, имя пункта меню и источник иконки типа Bitmap.
В примере истоники:
1) иконка, которая грузится из ресурса.
2) иконка из PictureBox на форме.

Иконки можно делать большего размера, тогда пункты меню тоже увеличатся.
Подгружать нужно в формате .bmp. Кол-во битов цветовой палитры не важно.
5
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar MenuIconLoader.rar (12.7 Кб, 13 просмотров)
xxdoc
4 / 4 / 0
Регистрация: 10.07.2015
Сообщений: 3
20.09.2017, 03:45 212
yes i upload
3
Вложения
Тип файла: zip Menu con Imagenes.zip (49.4 Кб, 13 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
20.09.2017, 07:59 213
Another 5 cents on the topic - the menu
author unknown
3
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Owner-draw Menu.rar (11.1 Кб, 7 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
04.10.2017, 22:45 214
Картинка в выпадающем списке

Возникла такая идея, а можно ли в расскрывающийся список ComboBox вставить чтото еще...

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
Option Explicit
 
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE = &H1
 
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
Private Type COMBOBOXINFO
    cbSize As Long
    rcItem As RECT
    rcButton As RECT
    stateButton As Long
    hWndCombo As Long
    hwndEdit As Long
    hWndList As Long
End Type
 
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetComboBoxInfo Lib "user32.dll" (ByVal hWndCombo As Long, ByRef CBInfo As COMBOBOXINFO) As Long
Private Declare Function SetParent Lib "user32.dll" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function IsWindowVisible Lib "user32.dll" (ByVal hwnd As Long) As Long
 
Dim WithEvents cbx As ComboBox, WithEvents tmr As Timer
Dim cbi As COMBOBOXINFO, rPic As RECT, www&
 
Private Sub Form_Activate()
    Set cbx = Controls.Add("vb.combobox", "cbx"): With cbx
        .Move 300, 300, 3000
        .Text = "Картинка в выпадающем списке"
        .Visible = 1
    End With
    Set tmr = Controls.Add("vb.timer", "tmr"): tmr.Interval = 100
    cbi.cbSize = Len(cbi)
    Call GetComboBoxInfo(cbx.hwnd, cbi)
    SetParent Picture1.hwnd, cbi.hWndList
    SetWindowPos Picture1.hwnd, 0, 0, 0, 0, 0, SWP_NOSIZE
End Sub
 
 
Private Sub tmr_Timer()
    Static b1 As Boolean, b2 As Boolean
    b1 = IsWindowVisible(cbi.hWndList)
    If b1 And b2 = False Then
        'Размер списка изменяется под картинку, только когда расскрывается список
        b2 = True: SetWindowPos cbi.hWndList, 0, 0, 0, Picture1.Width \ 15, Picture1.Height \ 15, SWP_NOMOVE
    ElseIf b1 = False And b2 Then
        b2 = False
    End If
End Sub
1
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Картинка в выпадающем списке.rar (18.6 Кб, 19 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
25.10.2017, 16:35 215
Хранилище данных

Представляю вниманию удобный инструмент для хранения своих записей
Возможности:
1-Создавать, удалять и редактировать каждую запись в отдельности
2-Находить нужную запись по фрагменту слова
3-Хранение данных в максимально сжатом виде (утилита Rar в комплекте)
4-Устанавливать и изменять пароль

Блог:

2
UBUNTU
209 / 134 / 29
Регистрация: 04.02.2015
Сообщений: 727
29.10.2017, 12:16 216
Отличный пример для генерации QR кода. Пример нашел на стороннем сайте, но источник с отсюда. Во вложении библиотека.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Option Explicit
 
Private Enum TErrorCorretion
    QualityLow
    QualityMedium
    QualityStandard
    QualityHigh
End Enum
 
Private Declare Sub GenerateBMP _
                Lib "D:\quricol32.dll" _
                Alias "GenerateBMPW" ( _
                ByVal FileName As Long, _
                ByVal Text As Long, _
                ByVal Margin As Long, _
                ByVal Size As Long, _
                ByVal Level As TErrorCorretion)
                
Private Sub Command1_Click()
On Error Resume Next
    GenerateBMP StrPtr("D:\Example.bmp"), StrPtr("Ваш текст!!!"), 3, 5, QualityLow
End Sub
5
Вложения
Тип файла: rar quricol32.rar (101.1 Кб, 13 просмотров)
Тип файла: rar quricol64.rar (92.9 Кб, 5 просмотров)
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
03.11.2017, 07:05 217
Оболочка к самому мощному в мире архиватору Paq9a

Нарыл в интернете консольную утилиту, и никак не смог найти к нему GUI - тоесть нормальный интерфейс
отказываться от впечатляещего инструмента архивирования и не собираюсь, разработал к нему интерфейс

Блог:




Результаты тестирования:
2
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
05.11.2017, 23:23 218
Новая версия MiniDataBase 1.2

1
kreotodr
27 / 25 / 8
Регистрация: 15.08.2014
Сообщений: 521
07.11.2017, 15:19 219
Задался целью выяснить действительно ли Орел/Решка выпадают с вероятностью 50/50...
В тесте использовал RND. Насколько это корректно не знаю...
после 1 000 000 000 процент стремится к 50/50

https://cdn1.radikalno.ru/uploads/20...28ed6-full.png
0
fever brain
oh my god
1121 / 595 / 115
Регистрация: 05.01.2016
Сообщений: 1,834
Записей в блоге: 7
13.11.2017, 07:41 220
Оболочка к самому мощному в мире архиватору Paq9a

================================== Версия 2-0
Что изменилось:
Мультиязычный интерфейс с возможностью расширения языков !
Есть возможность перетаскивать файлы для архивации Drag-and-Drop
Извлечение с указанием целевой папки
что это значит:
Тоесть если в самом архиве указан абсолютный путь, в своей программе
я подставляю путь целевой папки к базовому имени файла


Настройка использования памяти ПК от 18mb до 1585mb
Это о чем я писал ранее, (ненастраевоемое значение 1-9)
Но пользоваться с осторожностью, лучше оставляйте среднее значение


Теперь есть строка состояния того, что делает приложение Paq9a
Есть возможность посмотреть список файлов в архиве
Версия портабельная, достаточно запустить приложение ArcPaq9a
и можно пользоваться

Блог:

2
13.11.2017, 07:41
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
13.11.2017, 07:41

Visual Basic Используя условный оператор if…then, if…then…else или if…then…elseif, разработайте проект для решения следующих заданий:
Пройдет ли кирпич со сторонами а, b и с сквозь прямоугольное отверстие со...

Visual Basic 6 и Visual Basic .NET - в чем различия?
Visual Basic и Visual studio это не одно и тоже? если нет то в чём разница, по...

Отличия версий Visual Basic 6.0 от Visual Basic 6.5?
У меня 3 вопроса: 1.Чем отличается версия Visual Basic 6.0 от Visual Basic...


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

Или воспользуйтесь поиском по форуму:
220
Ответ Создать тему
Опции темы

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