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

Visual Basic

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
fever brain
Экстрасенс
726 / 264 / 63
Регистрация: 05.01.2016
Сообщений: 762
Записей в блоге: 3
29.05.2016, 07:52     Готовые решения и полезные коды на Visual Basic 6.0 #161
MediaPlayer

Ссылка


Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
29.05.2016, 07:52     Готовые решения и полезные коды на 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
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.06.2016, 12:09     Готовые решения и полезные коды на Visual Basic 6.0 #162
Распознавание речи используя API.AI
Небольшой пример использования средств API.AI для распознавания голосовых команд.
Вложения
Тип файла: zip API_AI.zip (12.9 Кб, 24 просмотров)
CharlyChaplin
120 / 12 / 1
Регистрация: 28.05.2015
Сообщений: 83
30.06.2016, 08:02     Готовые решения и полезные коды на Visual Basic 6.0 #163
Не так давно мой друг попросил прислать ему программу, которая не позволяла бы пользователям запускать запрещённые приложения. Решил заодно выложить её сюда.

Можно, конечно, было найти что-нибудь в Интернете, но захотелось сделать что-то своё. Написал простенькую программу, которая будет не блокировать, но моментально закрывать запрещённое приложение. Так как друга зовут Сергей, то и код активации такой же - в справке написано. Исходник, естественно, можно изменить. Времени на написание было всего 2 дня - код сыроват, но вполне работоспособен.

Тестировал только на Win7 x64.
Единственная проблема: здесь используются хуки для перехвата нажатия пароля для активации окна программы, следовательно, во время отслеживания сложно печатать тексты, т.к. иногда нажатия "поглощаются" и буква не печатается - нужно повторно её нажимать. Так как времени у меня было мало эта незначительная проблема осталась и я пока не знаю как её решить, но программа рабочая.

Перед использованием желательно прочитать справку, нажав на "?".
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip Слежение и закрытие программ.zip (23.1 Кб, 29 просмотров)
CharlyChaplin
120 / 12 / 1
Регистрация: 28.05.2015
Сообщений: 83
30.06.2016, 08:20     Готовые решения и полезные коды на Visual Basic 6.0 #164
Есть на проекте games.mail.ru игра "Виселица". Именно под неё я и написал небольшую программу. К ней приложен *.txt-словарь. Есть и своя небольшая справка. Интерфейс интуитивно-понятный. Есть подобного рода программы в Интернете, но свою реализацию я считаю лучшей. Тем более, благодаря ей, у меня самый большой процент выигрышей, что видно на скрине.:-) Очень не хотелось выкладывать исходник, но всё же решился.

Пользуйтесь.
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0   Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip HELP_Viselica.zip (382.1 Кб, 12 просмотров)
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.07.2016, 10:46     Готовые решения и полезные коды на Visual Basic 6.0 #165
TrickSound - класс для работы с аудио.

Привет всем!
Этот класс предоставляет простой интерфейс для захвата и воспроизведения звука. Он также не требует никаких дополнительных зависимостей и работает автономно. Объект данного класса генерирует событие NewData когда устройство захвата заполняет внутренний буфер звуковыми данными или устройству воспроизведения требуется очередная порция звуковых данных. Для того чтобы инициализировать воспроизведение вызовите метод InitPlayback, для захвата InitCapture. Затем нужно вызвать StartProcess для того чтобы начать воспроизведение/захват. Я сделал два примера использования этого класса: простой синтезатор и простой диктофон.
Вложения
Тип файла: zip TrickSound.zip (14.3 Кб, 8 просмотров)
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.07.2016, 11:04     Готовые решения и полезные коды на Visual Basic 6.0 #166
MP3 -> WAV конвертер.
Всем привет!
Представляю простую реализацию конвертера MP3 файлов в WAV используя ACM.
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip Mp3_to_wave.zip (5.7 Кб, 8 просмотров)
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.07.2016, 11:55     Готовые решения и полезные коды на Visual Basic 6.0 #167
Шифрование EXE файла.

Всем привет!
Представляю пример реализации простого шифрования EXE файла на основе файла лицензии. При некорректном файле лицензии EXE не запустится и выдаст сообщение об ошибочной лицензии, большинство кода будет зашифрованным, в ином случае EXE сам расшифровывает свой код и запускается.
Как это работает?
Во-первых, чтобы была возможность расшифровывать EXE нужно чтобы код расшифровки не шифровался. Для этого в коде используются функции маркеры: BEGIN_OF_NON_ENCRYPTABLE_REGION и END_OF_NON_ENCRYPTABLE_REGION. Код между ними будет нетронут.
Во-вторых, для шифрования файла нужно запустить его с параметром crypt:[файл лицензии], к примеру:
MyExe.exe crypt:license.lic
В этом случае EXE запускает процедуру самошифрования. В качестве файла лицензии может использоваться любой непустой файл. Если файл уже зашифрован - то возникнет ошибка. Для идентификации зашифрован ли файл используется поле VBHeader.pProjectInfo->dwNull которое не используется в скомпилированном файле и мы можем хранить любую информацию там. Я храню там контрольную сумму, где старший бит определяет факт шифрования.
В общем процедура шифрования определяет границы исполняемого кода и XOR'ит его с файлом лицензии, который выступает как кольцевой буфер. Потом контрольная сумма оригинальных данных сохраняется в вышеуказанное поле EXE файла. Шифрованный файл сохраняется как [ModuleName]__encrypted.[extension] в той же директории, оригинальный файл не изменяется.
Теперь если запустить файл то программа сначала проверит файл лицензии (он должен называться license.lic и лежать в директории EXE) и если попытается расшифровать его, одновременно вычисляя контрольную сумму. Если после полной расшифровки сумма совпадает - файл успешно расшифрован и запускается основной код, в противном случае выводится сообщение об ошибке.
Вот пример это код до шифрования:
Готовые решения и полезные коды на Visual Basic 6.0
Этот код после:
Готовые решения и полезные коды на Visual Basic 6.0
Спасибо за внимание!
Вложения
Тип файла: zip CryptExe.zip (101.1 Кб, 24 просмотров)
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.07.2016, 12:20     Готовые решения и полезные коды на Visual Basic 6.0 #168
Клонирование директории в отдельном потоке.

Нередко возникает необходимость копирования директории с ее структурой в другое место. Для этого идеально подходит метод FileSystemObject::CopyFolder, но во-первых он блокирует вызывающий поток до полного завершения, а также не имеет никаких интерфейсов для получения состояния процесса копирования. Для обхода первого ограничения достаточно всего-лишь вызвать метод в другом потоке, но второе ограничение уже никак не обойти (документированными способами).
В качестве пополнения примеров многопоточности для своего кирпича, я решил создать небольшое приложение позволяющее получать расширенную информацию во время копирования директории не блокирующее основной GUI поток. Для межпоточного обмена данными используется APC очередь, с помощью которой доставляется сообщение из потока копирования в главный поток. В качестве уведомления используется интерфейс ICopyFolderNotify, который реализуется необходимым объектом и получает уведомления из другого потока. Пример достаточно сложен, но содержит некоторые особенности работы с многопоточностью на VB6 (ручное копирование переменных между потоками).
Для работы нужно либо взять tlb отсюда, либо использовать DLL раскоментровав API vbCreateThread. Пример работает и в IDE и в скомпилированном виде (в IDE запуск в основном потоке).
Спасибо за внимание.
Вложения
Тип файла: zip Multithreading_CopyFolder.zip (8.3 Кб, 6 просмотров)
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
08.07.2016, 12:52     Готовые решения и полезные коды на Visual Basic 6.0 #169
Получение миниатюр изображений в отдельном потоке.

Всем привет!
Как-то меня попросил один человек сделать ему пример в котором будут извлекаться миниатюры изображений в какое-либо хранилище, и чтобы это не блокировало основной поток. В качестве пополнения базы примеров для своего кирпича я сделал этот пример. В этом примере извлекаются все возможные изображения из указанной директории и создаются превью, которые помещаются в объект потока (IStream). Связь между потоками осуществляется через оконные сообщения, для этого используется мой класс безопасного сабклассинга.
Вложения
Тип файла: zip AsynchSplitter.zip (10.1 Кб, 11 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
14900 / 6503 / 792
Регистрация: 25.12.2011
Сообщений: 10,042
Записей в блоге: 15
05.08.2016, 02:10  [ТС]     Готовые решения и полезные коды на Visual Basic 6.0 #170
Перечисление файлов тома NTFS, используя Master File Table и USN Journal

Поиск файлов на основе этого метода ~ от 10 до 200 раз быстрее, чем стандартный FindFirstFile / FindNextFile, т.к. информация берётся напрямую из MFT (скорость больше зависит от процессора и дописанной Вами логики).

Подобный движок используется в программе 'Everything'.

Из минусов:
- требуются повышенные привилегии.
- поддерживаются только тома NTFS (и ReFS).

Демо без интерфейса.
В примере - вывод в окно отладки всех файлов .lnk на диске C: (исключаются папки и симлинки).

Функция FindAllFiles(szDriveLetter, ExcludeMask, ExtMask), где:

szDriveLetter - буква диска
ExcludeMask - битовая маска исключаемых атрибутов файловых объектов
ExtMask - искомое расширение имени файла

Как конструируется полный путь к файлу:
В журнале USN хранятся только имена файловых объектов и ссылки на родительский каталог.
Итого есть 2 способа получить полный путь:

1) создать полное дерево.
Минус:
- программа скушает очень много памяти.
Плюс:
- это работает быстрее, если Вашей задачей является обязательное перечисление полных имен ВСЕХ файлов.
- можно изменить код таким образом, чтобы отображались удалённые файлы. Полный путь к ним можно будет получить только, имея дерево ссылок.
2) открыв файл и затем через NtQueryInformationFile.
Минус:
- файл может быть заблокирован.
- актуально, только если нужно искать по имени, а в результатах поиска ожидается небольшое кол-во файлов (скажем ~ до 1000).

У меня сделано по варианту №2. Результат в переменной sFullPath.

Исходник
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
Option Explicit
 
Private Const INVALID_HANDLE_VALUE  As Long = -1&
Private Const GENERIC_READ          As Long = &H80000000
Private Const FILE_GENERIC_READ     As Long = 4&
Private Const FILE_SHARE_READ       As Long = &H1&
Private Const FILE_SHARE_WRITE      As Long = &H2&
Private Const OPEN_EXISTING         As Long = 3&
Private Const FileNameInformation   As Long = 9&
Private Const FILE_FLAG_BACKUP_SEMANTICS As Long = &H2000000
Private Const FILE_OPEN_FOR_BACKUP_INTENT As Long = &H4000&
Private Const FILE_OPEN_BY_FILE_ID  As Long = &H2000&
Private Const FILE_OPEN             As Long = &H1&
Private Const OBJ_CASE_INSENSITIVE  As Long = &H40&
Private Const FSCTL_ENUM_USN_DATA   As Long = &H900B3
Private Const FILE_ATTRIBUTE_REPARSE_POINT As Long = &H400&
Private Const FILE_ATTRIBUTE_SPARSE_FILE As Long = &H200&
 
Private Type MFT_ENUM_DATA
    StartFileReferenceNumber    As Currency
    LowUsn                      As Currency
    HighUsn                     As Currency
End Type
 
Private Type USN_RECORD
    RecordLength    As Long
    MajorVersion    As Integer
    MinorVersion    As Integer
    FileReferenceNumber As Currency
    ParentFileReferenceNumber As Currency
    Usn             As Currency
    TimeStamp       As Currency
    Reason          As Long
    SourceInfo      As Long
    SecurityId      As Long
    FileAttributes  As Long
    FileNameLength  As Integer
    FileNameOffset  As Integer
    'WCHAR         FileName[1];
End Type
 
Private Type IO_STATUS_BLOCK
    Status      As Long
    Information As Long
End Type
 
Private Type UNICODE_STRING
    Length          As Integer
    MaximumLength   As Integer
    buffer          As Long
End Type
 
Private Type OBJECT_ATTRIBUTES
    Length                   As Long
    RootDirectory            As Long
    ObjectName               As Long
    Attributes               As Long
    SecurityDescriptor       As Long
    SecurityQualityOfService As Long
End Type
 
Private Declare Function DeviceIoControl Lib "kernel32.dll" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As MFT_ENUM_DATA, ByVal nInBufferSize As Long, ByVal lpOutBuffer As Long, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function NtQueryInformationFile Lib "NTDLL.DLL" (ByVal FileHandle As Long, IoStatusBlock_Out As IO_STATUS_BLOCK, ByVal lpFileInformation As Long, ByVal Length As Long, ByVal FileInformationClass As Long) As Long
Private Declare Function NtCreateFile Lib "NTDLL.DLL" (FileHandle As Long, ByVal DesiredAccess As Long, ByVal ObjectAttributes As Long, ioStatusBlock As IO_STATUS_BLOCK, ByVal AllocationSize As Long, ByVal FileAttribs As Long, ByVal SharedAccess As Long, ByVal CreationDisposition As Long, ByVal CreateOptions As Long, ByVal EaBuffer As Long, ByVal EaLength As Long) As Long
Private Declare Sub memcpy Lib "kernel32.dll" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetMem4 Lib "msvbvm60.dll" (src As Any, dst As Any) As Long
Private Declare Function GetMem8 Lib "msvbvm60.dll" (src As Any, dst As Any) As Long
Private Declare Function lstrcpyn Lib "kernel32.dll" Alias "lstrcpynW" (ByVal lpDst As Long, ByVal lpSrc As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
 
Private Sub Form_Load()
    Dim t!
    
    t = Timer
    
    'no folders, no symlinks
    FindAllFiles "C:", vbDirectory Or FILE_ATTRIBUTE_REPARSE_POINT Or FILE_ATTRIBUTE_SPARSE_FILE, ".lnk"
    
    Debug.Print Timer - t
 
End Sub
 
Private Function OpenVolume(ByVal szDriveLetter As String) As Long
 
    Dim hVolume As Long
 
    hVolume = CreateFile(StrPtr("\\." & szDriveLetter), GENERIC_READ, _
                         FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0&, 0&)
 
    OpenVolume = hVolume
    
    If hVolume = INVALID_HANDLE_VALUE Then
        Debug.Print "Couldn't open handle to the volume."
    End If
End Function
 
Public Sub FindAllFiles(szDriveLetter As String, ExcludeMask As Long, ExtMask As String)
 
    Dim usnRecord    As USN_RECORD
    Dim mft          As MFT_ENUM_DATA
    Dim dwRetBytes   As Long
    Dim cb           As Long
    Dim pUsnRecord   As Long
    Dim bIsFile      As Boolean
    Dim m_Buffer()   As Byte
    Dim m_BufferSize As Long
    Dim hVolume      As Long
    Dim lret         As Long
    Dim sFileName    As String
    Dim cntFiles     As Long
    Dim sFullPath    As String
    
    hVolume = OpenVolume(szDriveLetter)
    
    If hVolume = INVALID_HANDLE_VALUE Then Exit Sub
 
    ExtMask = LCase$(ExtMask)
 
    m_BufferSize = 65536 '64KB
    
    ReDim m_Buffer(m_BufferSize - 1)
    
    mft.StartFileReferenceNumber = 0
    mft.LowUsn = 0
    mft.HighUsn = 922337203685477.5807@ 'all sequences
    
    Do
        DoEvents
    
        lret = DeviceIoControl(hVolume, FSCTL_ENUM_USN_DATA, mft, LenB(mft), VarPtr(m_Buffer(0)), m_BufferSize, dwRetBytes, 0&)
        
        If lret Then
            cb = dwRetBytes
            
            GetMem8 m_Buffer(0), mft.StartFileReferenceNumber
            pUsnRecord = 8 'skip next USN
            
            Do While (dwRetBytes > 8)
                
                memcpy usnRecord, m_Buffer(pUsnRecord), LenB(usnRecord)
                
                If Not CBool(usnRecord.FileAttributes And ExcludeMask) Then
                    With usnRecord
                        If .FileNameLength <> 0 Then
                            sFileName = String$(.FileNameLength \ 2, 0)
                            lstrcpyn StrPtr(sFileName), VarPtr(m_Buffer(pUsnRecord)) + .FileNameOffset, .FileNameLength \ 2 + 1
                            
                            If StrEndWith(sFileName, ExtMask) Then
                                sFullPath = GetPathFromFileReference(hVolume, szDriveLetter, sFileName, .FileReferenceNumber)
                                If Len(sFullPath) <> 0 Then
                                    Debug.Print sFullPath
                                Else
                                    Debug.Print sFileName
                                End If
                                cntFiles = cntFiles + 1
                            End If
                        End If
                    End With
                End If
                
                'ptr to the next record in the buffer
                pUsnRecord = pUsnRecord + usnRecord.RecordLength
                dwRetBytes = dwRetBytes - usnRecord.RecordLength
            Loop
                
        End If
 
    Loop Until cb <= 8 Or lret = 0
    
    CloseHandle hVolume
    
    Debug.Print "Total Files on " & szDriveLetter & " is - " & cntFiles
End Sub
 
Private Function StrEndWith(Text As String, LastPart As String) As Boolean
    StrEndWith = (StrComp(Right$(Text, Len(LastPart)), LastPart, 1) = 0)
End Function
 
Private Function GetPathFromFileReference(hVolume As Long, szDriveLetter As String, sFileName As String, frn As Currency) As String
 
    Dim objAttrib   As OBJECT_ATTRIBUTES
    Dim UniStr      As UNICODE_STRING
    Dim IO_Status   As IO_STATUS_BLOCK
    Dim lret        As Long
    Dim buf()       As Byte
    Dim nameLength  As Long
    Dim path        As String
    Dim hFile       As Long
 
    With UniStr
        .Length = 8
        .MaximumLength = 8
        .buffer = VarPtr(frn)
    End With
 
    With objAttrib
        .Length = LenB(objAttrib)
        .ObjectName = VarPtr(UniStr)
        .RootDirectory = hVolume
        .Attributes = OBJ_CASE_INSENSITIVE
    End With
 
    lret = NtCreateFile(hFile, FILE_GENERIC_READ, VarPtr(objAttrib), IO_Status, 0&, 0&, _
                        FILE_SHARE_READ Or FILE_SHARE_WRITE, FILE_OPEN, FILE_OPEN_BY_FILE_ID Or FILE_OPEN_FOR_BACKUP_INTENT, 0&, 0&)
    
    If lret = 0 Then
    
        ReDim buf(32767 * 2& + 4 - 1)
        
        lret = NtQueryInformationFile(hFile, IO_Status, VarPtr(buf(0)), UBound(buf) + 1, FileNameInformation)
        
        If lret = 0 Then
            GetMem4 buf(0), nameLength
            path = String$(nameLength \ 2, 0)
            lstrcpyn StrPtr(path), VarPtr(buf(4)), nameLength \ 2 + 1
            GetPathFromFileReference = szDriveLetter & path
        Else
            Debug.Print "Couldn't obtain path information for: " & sFileName
        End If
        
        CloseHandle hFile
    Else
        Debug.Print "Couldn't open file handle for: " & sFileName
    End If
End Function


Возможно, если будет время, распишу в блоге более подробно, как работает и что ещё может эта штука и в каких целях можно её использовать.
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
24.08.2016, 00:16     Готовые решения и полезные коды на Visual Basic 6.0 #171
Удаление всех ресурсов после выполнения программы.



Всем привет. Я бы хотел продемонстрировать небольшой проект, который содержит модуль для удаления файлов после завершения работы EXE. Это может быть полезно к примеру для программы которая использует какие-либо библиотеки для своей работы и нужно обеспечить удаление этих компонентов с жесткого диска после выполнения программы. Этот модуль позволяет даже удалить собственный EXE после завершения работы.
Принцип работы очень прост, модуль содержит шеллкод написанный на VB6 который внедряется в процесс "зомби" и ждет завершения программы. После завершения программы шеллкод удаляет файлы которые пользователь передал в него, т.е. исключаются какие-либо блокировки со стороны EXE файла, поэтому мы можем все удалять даже сам EXE. После выполнения всех действий шеллкод завершает работу процесса "зомби".
Сам модуль:
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
' //
' // modSelfCleaning by The trick
' //
 
Option Explicit
 
Private Const STARTF_USESHOWWINDOW      As Long = &H1
Private Const SW_HIDE                   As Long = 0
Private Const CREATE_SUSPENDED          As Long = &H4
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE               As Long = &H2000&
Private Const MEM_RELEASE               As Long = &H8000&
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const DUPLICATE_SAME_ACCESS     As Long = &H2
Private Const DUPLICATE_CLOSE_SOURCE    As Long = &H1
Private Const INFINITE                  As Long = &HFFFFFFFF
Private Const WAIT_OBJECT_0             As Long = 0
 
Private Type tFunctionsTable
    pWaitForSingleObject    As Long
    pExitProcess            As Long
    pCloseHandle            As Long
    pDeleteFile             As Long
    plstrlen                As Long
End Type
 
Private Type tThreadData
    lNumberOfEntries        As Long            ' // Number of items in strings table
    pStringTable            As Long            ' // Pointer to strings table
    tFuncTable              As tFunctionsTable ' // Functions table
    hMainExe                As Long            ' // Handle of main exe
End Type
 
Private Type PROCESS_INFORMATION
    hProcess                As Long
    hThread                 As Long
    dwProcessId             As Long
    dwThreadId              As Long
End Type
 
Private Type STARTUPINFO
    cb                      As Long
    lpReserved              As Long
    lpDesktop               As Long
    lpTitle                 As Long
    dwX                     As Long
    dwY                     As Long
    dwXSize                 As Long
    dwYSize                 As Long
    dwXCountChars           As Long
    dwYCountChars           As Long
    dwFillAttribute         As Long
    dwFlags                 As Long
    wShowWindow             As Integer
    cbReserved2             As Integer
    lpReserved2             As Long
    hStdInput               As Long
    hStdOutput              As Long
    hStdError               As Long
End Type
 
Private Declare Function CreateProcess Lib "kernel32" _
                         Alias "CreateProcessW" ( _
                         ByVal lpApplicationName As Long, _
                         ByVal lpCommandLine As Long, _
                         lpProcessAttributes As Any, _
                         lpThreadAttributes As Any, _
                         ByVal bInheritHandles As Long, _
                         ByVal dwCreationFlags As Long, _
                         lpEnvironment As Any, _
                         ByVal lpCurrentDirectory As Long, _
                         lpStartupInfo As STARTUPINFO, _
                         lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
                         ByVal hObject As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                         Alias "GetModuleHandleW" ( _
                         ByVal lpModuleName As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
                         ByVal hModule As Long, _
                         ByVal lpProcName As String) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" ( _
                         ByVal hProcess As Long, _
                         lpAddress As Any, _
                         ByVal dwSize As Long, _
                         ByVal flAllocationType As Long, _
                         ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" ( _
                         ByVal hProcess As Long, _
                         lpAddress As Any, _
                         ByVal dwSize As Long, _
                         ByVal dwFreeType As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" ( _
                         ByVal hSourceProcessHandle As Long, _
                         ByVal hSourceHandle As Long, _
                         ByVal hTargetProcessHandle As Long, _
                         ByRef lpTargetHandle As Any, _
                         ByVal dwDesiredAccess As Long, _
                         ByVal bInheritHandle As Long, _
                         ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function WriteProcessMemory Lib "kernel32" ( _
                         ByVal hProcess As Long, _
                         ByVal lpBaseAddress As Long, _
                         lpBuffer As Any, _
                         ByVal nSize As Long, _
                         lpNumberOfBytesWritten As Long) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" ( _
                         ByVal hProcess As Long, _
                         lpThreadAttributes As Any, _
                         ByVal dwStackSize As Long, _
                         ByVal lpStartAddress As Long, _
                         lpParameter As Any, _
                         ByVal dwCreationFlags As Long, _
                         lpThreadId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" ( _
                         ByVal hProcess As Long, _
                         ByVal uExitCode As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    ByRef Destination As Any, _
                    ByRef Source As Any, _
                    ByVal Length As Long)
               
' // Wait for program termination and delete all passed files
Public Function CleanFiles( _
                ParamArray vFiles() As Variant) As Boolean
    Dim tdParam     As tThreadData
    Dim bStrTable() As Byte
    Dim hKernel32   As Long
    Dim hProcess    As Long
    Dim hThread     As Long
    Dim pData       As Long
    Dim pParam      As Long
    Dim pCode       As Long
    Dim lDataSize   As Long
    Dim lCodeSize   As Long
    Dim bRet        As Long
    Dim bInIDE      As Boolean
    
    ' // Check if code is in ide
    Debug.Assert MakeTrue(bInIDE)
    
    If bInIDE Then
        
        MsgBox "You should compile to Native code", vbExclamation
        CleanFiles = True
        Exit Function
        
    End If
    
    ' // Setup TrickCallPointers
    PatchFunc AddressOf CloseHandle_Proto
    PatchFunc AddressOf DeleteFileW_Proto
    PatchFunc AddressOf ExitProcess_Proto
    PatchFunc AddressOf lstrlenW_Proto
    PatchFunc AddressOf WaitForSingleObject_Proto
    
    hKernel32 = GetModuleHandle(StrPtr("kernel32"))
    If hKernel32 = 0 Then
        GoTo CleanUp
    End If
    
    ' // Fill functions table
    With tdParam.tFuncTable
    
        .pCloseHandle = GetProcAddress(hKernel32, "CloseHandle")
        .pDeleteFile = GetProcAddress(hKernel32, "DeleteFileW")
        .pExitProcess = GetProcAddress(hKernel32, "ExitProcess")
        .pWaitForSingleObject = GetProcAddress(hKernel32, "WaitForSingleObject")
        .plstrlen = GetProcAddress(hKernel32, "lstrlenW")
    
    End With
    
    ' // Make string table
    tdParam.lNumberOfEntries = StringTableToByteArray(bStrTable(), vFiles)
    If tdParam.lNumberOfEntries = 0 Then
        GoTo CleanUp
    End If
    
    ' // Run "Zombie" process
    hProcess = RunZombieProcess()
    If hProcess = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place handle of main exe
    If DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(), hProcess, _
                        tdParam.hMainExe, 0, False, DUPLICATE_SAME_ACCESS) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Alloc memory in the EXE
    lCodeSize = GetAddress(AddressOf END_OF_SHELLCODE) - GetAddress(AddressOf BEGIN_OF_SHELLCODE)
    lDataSize = UBound(bStrTable) + 1 + LenB(tdParam) + lCodeSize
    
    pData = VirtualAllocEx(hProcess, ByVal 0&, lDataSize, _
                           MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
    If pData = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place string table
    If WriteProcessMemory(hProcess, pData, bStrTable(0), UBound(bStrTable) + 1, 0) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place param
    tdParam.pStringTable = pData
    
    pParam = pData + UBound(bStrTable) + 1
    
    If WriteProcessMemory(hProcess, pParam, tdParam, LenB(tdParam), 0) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Place code
    pCode = pParam + LenB(tdParam)
    
    If WriteProcessMemory(hProcess, pCode, ByVal GetAddress(AddressOf ShellcodeProc), lCodeSize, 0) = 0 Then
        GoTo CleanUp
    End If
    
    ' // Run code
    hThread = CreateRemoteThread(hProcess, ByVal 0&, 0, pCode, ByVal pParam, 0, 0)
    If hThread = 0 Then
        GoTo CleanUp
    End If
    
    bRet = True
    
CleanUp:
    
    CloseHandle hThread
    
    If Not bRet Then
        
        If pData Then
            VirtualFreeEx hProcess, ByVal pData, 0, MEM_RELEASE
        End If
        
        If tdParam.hMainExe Then
            DuplicateHandle hProcess, tdParam.hMainExe, 0, 0, ByVal 0&, 0, DUPLICATE_CLOSE_SOURCE
        End If
        
        If hProcess Then
            TerminateProcess hProcess, 0
            CloseHandle (hProcess)
        End If
        
    End If
    
    CleanFiles = bRet
    
End Function
 
' // Run "Zombie" process
Private Function RunZombieProcess() As Long
    Dim pi  As PROCESS_INFORMATION
    Dim si  As STARTUPINFO
    
    si.cb = Len(si)
    si.dwFlags = STARTF_USESHOWWINDOW
    si.wShowWindow = SW_HIDE
    
    If CreateProcess(StrPtr(Environ("ComSpec")), 0, ByVal 0&, ByVal 0&, False, CREATE_SUSPENDED, ByVal 0, 0, si, pi) = 0 Then
        Exit Function
    End If
    
    CloseHandle pi.hThread
    
    RunZombieProcess = pi.hProcess
    
End Function
 
' // Serialize string table
Private Function StringTableToByteArray( _
                 ByRef bOutData() As Byte, _
                 ParamArray vStringTable() As Variant) As Long
    Dim bData()     As Byte:    Dim lDataCount      As Long
    Dim lIndex      As Long:    Dim sTmpString      As String
    Dim vVar        As Variant
    
    For Each vVar In vStringTable(0)
        
        If VarType(vVar) <> vbString Then GoTo continue
        
        sTmpString = vVar
 
        ReDim Preserve bData(lDataCount + LenB(sTmpString) + 2)
        
        ' // Copy string to buffer with null-terminating character
        CopyMemory bData(lDataCount), ByVal StrPtr(sTmpString), LenB(sTmpString) + 2
        
        lDataCount = lDataCount + LenB(sTmpString) + 2
        
        StringTableToByteArray = StringTableToByteArray + 1
        
continue:
        
    Next
    
    bOutData() = bData
 
End Function
                 
Private Function GetAddress( _
                 ByVal pAddress As Long) As Long
    GetAddress = pAddress
End Function
                 
Private Function BEGIN_OF_SHELLCODE() As Long
    BEGIN_OF_SHELLCODE = 1
End Function
 
Private Sub ShellcodeProc( _
            ByRef tdParam As tThreadData)
    Dim lIndex  As Long
    
    With tdParam
    
        ' // Wait process termination
        If WaitForSingleObject_Proto(.tFuncTable.pWaitForSingleObject, .hMainExe, INFINITE) <> WAIT_OBJECT_0 Then
            Exit Sub
        End If
        
        For lIndex = 0 To .lNumberOfEntries - 1
            
            DeleteFileW_Proto .tFuncTable.pDeleteFile, .pStringTable
            
            ' // Next string
            .pStringTable = .pStringTable + (lstrlenW_Proto(.tFuncTable.plstrlen, .pStringTable) + 1) * 2
            
        Next
        
        ' // Close handle
        CloseHandle_Proto .tFuncTable.pCloseHandle, .hMainExe
        
        ' // Exit process
        ExitProcess_Proto .tFuncTable.pExitProcess, 0
        
    End With
    
End Sub
 
Private Function WaitForSingleObject_Proto( _
                 ByVal pAddress As Long, _
                 ByVal hHandle As Long, _
                 ByVal dwMilliseconds As Long) As Long
End Function
 
Private Sub ExitProcess_Proto( _
            ByVal pAddress As Long, _
            ByVal uExitCode As Long)
End Sub
 
Private Function CloseHandle_Proto( _
                 ByVal pAddress As Long, _
                 ByVal hObject As Long) As Long
End Function
 
Private Function DeleteFileW_Proto( _
                 ByVal pAddress As Long, _
                 ByVal lpFileName As Long) As Long
End Function
 
Private Function lstrlenW_Proto( _
                 ByVal pAddress As Long, _
                 ByVal lpString As Long) As Long
End Function
 
Private Function END_OF_SHELLCODE() As Long
    END_OF_SHELLCODE = 2
End Function
Для того чтобы обеспечить удаление файлов после работы EXE нужно вызвать функцию CleanFiles передавая в качестве параметра список файлов для удаления. Можно вызвать эту функцию как в начале работы приложения, в этом случае файлы будут удалены даже если приложение завершилось аварийно, так и в конце работы приложения.
Этот модуль использует модуль modTrickCallPointers для вызова функций по указателю. В аттаче небольшой пример использования который распаковывает внутренний OCX, а после завершения приложения удаляет его и собственный EXE файл.
Вложения
Тип файла: zip SelfCleaning.zip (119.0 Кб, 5 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
14900 / 6503 / 792
Регистрация: 25.12.2011
Сообщений: 10,042
Записей в блоге: 15
25.08.2016, 18:22  [ТС]     Готовые решения и полезные коды на Visual Basic 6.0 #172
Удаление ресурсов после выполнения программы.

Похожий по своим целям код, работающий по другим принципам.

Используется для создания портативных приложений, для которых необходимо автоматически зачищать всё, что было распаковано из своих ресурсов.

В приложенном примере после запуска EXE распаковывается MsComCtl.ocx, затем создаётся экземпляр формы, которая использует этот OCX без регистрации (использован SxS манифест).
При завершении процесса, создается процесс-клон, куда передается PID оригинального процесса через командную строку.
Этот клон следит пока завершится процесс № 1, после чего удаляет OCX и завершается сам.

Ограничения метода:
- точкой входа должен быть стандартный модуль, либо форма, которая не использует OCX (например, пустая форма, которая запустит форму № 2, а сама станет скрытой).
Смысл в том, чтобы в момент запуска процесса, он не использовал ресурсы.

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
Option Explicit
 
Private Type tagINITCOMMONCONTROLSEX
    dwSize  As Long
    dwICC   As Long
End Type
 
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
 
Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
 
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessW" (ByVal lpApplicationName As Long, ByVal lpCommandLine As Long, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function DeleteFileW Lib "kernel32.dll" (ByVal lpFileName As Long) As Long
Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoW" (lpStartupInfo As STARTUPINFO)
 
 
Sub Main()
    InitVisualStyles
    
    If InStr(1, Command(), "/release", 1) <> 0 Then
        'Если мы - клон, ожидать завершения PID, переданного через аргументы командной строки, после чего удалить файлы
        WatchForProcess
        Exit Sub
    End If
        
    'распаковать ocx, используемый формой
    UnpackResource 101, App.Path & "" & "MSComCtl.ocx"
    
    'Показать форму в синхронном режиме
    Form2.Show vbModal
    Set Form2 = Nothing
    
    ' запустить процесс-клон для слежения за завершением первичного процесса и последующим удалением остатков (OCX)
    Release
End Sub
 
Sub Release()
    On Error GoTo ErrorHandler
    
    Const STARTF_USESHOWWINDOW      As Long = 1
    Const NORMAL_PRIORITY_CLASS     As Long = &H20
    
    If True Then
        Dim si As STARTUPINFO
        Dim pi As PROCESS_INFORMATION
        Dim lret As Long
        
        si.cb = Len(si)
        GetStartupInfo si
        si.dwFlags = STARTF_USESHOWWINDOW
        si.wShowWindow = vbHide
    
        lret = CreateProcess(ByVal 0&, _
                       StrPtr("""" & App.Path & "" & App.EXEName & """" & " " & """" & "/release:" & GetCurrentProcessId() & """"), _
                       ByVal 0&, _
                       ByVal 0&, _
                       False, _
                       NORMAL_PRIORITY_CLASS, _
                       ByVal 0&, _
                       0&, _
                       si, _
                       pi)
        
        CloseHandle pi.hThread
        CloseHandle pi.hProcess
    End If
    Exit Sub
ErrorHandler:
    ErrorMsg Err, "Release"
End Sub
 
Sub WatchForProcess()
    On Error GoTo ErrorHandler
    Const INFINITE                  As Long = -1
    Const SYNCHRONIZE               As Long = &H100000
    Const PROCESS_QUERY_INFORMATION As Long = 1024&
    Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
    
    Dim ProcessID As Long
    Dim hProc As Long
    Dim lret As Long
    
    ProcessID = Val(Mid$(Command(), InStr(1, Command(), "/release:", 1) + Len("/release:")))
    
    If ProcessID <> 0 Then
        
        hProc = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, False, ProcessID)
    
        If hProc <> 0 Then
            Call WaitForSingleObject(hProc, INFINITE)
            CloseHandle hProc
        End If
            
        lret = DeleteFileW(StrPtr(App.Path & "" & "MSComCtl.ocx"))
    End If
    Exit Sub
ErrorHandler:
    ErrorMsg Err, "WatchForProcess"
End Sub
 
Sub InitVisualStyles()
    Dim ICC As tagINITCOMMONCONTROLSEX
    With ICC
        .dwSize = Len(ICC)
        .dwICC = &HFF&
    End With
    InitCommonControlsEx ICC
End Sub
 
Public Function UnpackResource(ResourceID As Long, DestinationPath As String) As Boolean
    On Error GoTo ErrorHandler:
    Dim ff      As Integer
    Dim b()     As Byte
    UnpackResource = True
    b = LoadResData(ResourceID, "CUSTOM")
    ff = FreeFile
    Open DestinationPath For Binary Access Write As #ff
        Put #ff, , b
    Close #ff
    Exit Function
ErrorHandler:
    ErrorMsg Err, "UnpackResource", "ID: " & ResourceID, "Destination path: " & DestinationPath
    UnpackResource = False
End Function
 
Sub ErrorMsg(ErrObj As ErrObject, sProcedure As String, ParamArray CodeModule())
    Dim Other$, sFormatted$, i&
    For i = 0 To UBound(CodeModule): Other = Other & CodeModule(i) & " ": Next
    sFormatted = " - " & sProcedure & " - #" & ErrObj.Number & " " & ErrObj.Description & ". LastDllError = " & ErrObj.LastDllError & IIf(Len(Other), "" & Other, "")
    Debug.Print sFormatted
End Sub

Не по теме:


The trick, не знаю как ты там на vbforums такое пишешь. Мне тот модератор все уши выел за этот и соседний проект и обещал забанить за выкладывание подобного несмотря на все объяснения в пару листов в ЛС. Лучший способ у них - отключить UAC. Тупая обезъяна...


В коде использован CreateProcess вместо обычной VB-шной функции Shell, т.к. она почему-то виснет на 10,5 сек. (так и не разобрался почему), если кому-то интересно, приложил демку Free_mem3.
Free_mem4 - аналог кода выше (на основе CreateProcess). Тестировать только в скомпилированном виде!
Вложения
Тип файла: zip Free_mem3.zip (946.8 Кб, 4 просмотров)
Тип файла: zip Free_mem4.zip (944.5 Кб, 4 просмотров)
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
14.09.2016, 19:44     Готовые решения и полезные коды на Visual Basic 6.0 #173
Загрузчик, шеллкод, без рантайма...



Статья из двух частей которая подробно описывает этапы создания EXE загрузчика на VB6. Это обновление моего предыдущего инсталлятора в котором досконально описывается каждый шаг его работы; также добавлена компрессия файлов. Немного описывается структура PE-файлов (в частности исполняемых). Некоторые недокументированные структуры Windows которые связаны с загрузочными модулями. Также присутствует подробное описание загрузки EXE файла из памяти минуя диск, обработка таблицы импорта, таблицы релокаций. Подробно описываются способы "отучения" VB6 приложений от рантайма что позволит запускать приложения в среде с отсутствующей библиотекой MSVBVM60. Также это поможет писать многопоточные приложения (без всяких дополнительных зависимостей) поскольку они имеют также ограничения на использование рантайма. В дополнение рассказывается о принципах написания шеллкода на VB6 что позволит писать приложение с внедрением кода в другие процессы и там выполнять какие-либо действия.

Часть 1.
Часть 2.
The trick
Модератор
6927 / 2391 / 741
Регистрация: 22.02.2013
Сообщений: 3,444
Записей в блоге: 74
28.09.2016, 11:08     Готовые решения и полезные коды на Visual Basic 6.0 #174
Trick Advanced Tools.



Всем привет!
Представляю вашему вниманию небольшую разработку - Add-in который позволяет в некоторой степени облегчить отладку некоторых программ, а также расширяет возможности компиляции. Все исходные коды прилагаются.
Данный Add-in имеет следующие возможности:
  • Исправляет баг с Not Not Array после которого часто выскакивала ошибка "Expression too complex" если начать работать с вещественными числами;
  • Позволяет использовать константы условной компиляции автоматически в зависимости от режима работы (IDE/EXE), как например в C++ (NDEBUG);
  • Позволяет отключать проверку переполнения целочисленных операций в IDE;
  • Позволяет отключать проверку операций с плавающей точкой в IDE;
  • Позволяет отключать проверку границ массивов в IDE;
  • Предоставляет события компиляции/линковки (для компиляции также в режиме работы в IDE/EXE), т.е. можно выполнять команды до и после этих событий. Используя эти события можно делать много чего полезного (шифрование, подмену OBJ файлов, статическую линковку и т.п)

Описание и файлы.
fever brain
Экстрасенс
726 / 264 / 63
Регистрация: 05.01.2016
Сообщений: 762
Записей в блоге: 3
30.09.2016, 19:11     Готовые решения и полезные коды на Visual Basic 6.0 #175
Здравствуйте друзья !
Спешу поделиться чемто новым
И как всегда надёжным и проверенным способом !!!
Программа Аккаунты, уверяю ! Всё продуманно учить не придётся )
Итак:
Хранение настроек находиться всегда в AppPath\User и тд тоесть норм. ВС сохранит ваши записи (проверял)
совместимость со всеми 2000 xp 7,8 (-проверил Обижающихся слушать не буду)
Итак:
Самая нужная, самая актуальная и правильная версия здесь:
Исходняк ...(и изжога для наших дедушек) на сайте

раз.. уж.. моей семейке понравилось:
ция и итд (сэкрэт)

Добавлено через 19 минут
Сэкрэкт W#1
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
Option Explicit
Option Compare Text
 
Public Const Grid = 90
Dim ll&, tt&, ww&, hh&, mL&, mT&
 
Public Enum MoveAction
    [По умолчанию] = -3
    [Новые пункты] = -1
    [Сверху вниз] = 0
    [Слева направо] = 1
    [Продолжить вниз] = 2
    [Продолжить вправо] = 3
End Enum
 
 
Public Type SetCtr
    Move As Long
    GridWidth As Long
    GridHeight As Long
    StartLeft As Long
    StartTop As Long
    Gaps As Boolean
    Container As Object
End Type
 
Dim mDic As Object, mShellApp As Object
Dim SetCtr As SetCtr
 
Public Sub LoadAction( _
    Optional ByVal Move As MoveAction = -3, _
    Optional ByVal StartLeft&, _
    Optional ByVal StartTop&, _
    Optional ByVal GridWidth&, _
    Optional ByVal GridHeight&, _
    Optional ByVal Gaps& = -1, _
    Optional ByVal Container As Object, _
    Optional ByVal Ctrl As Object, _
    Optional ByVal Count&, _
    Optional ByVal Property$)
 
'Процедура для динамического создания контролов и назначения свойств всей группе
'Разделители: \\ для списков. //-для переменных в сходных свойствах. также будет загружен новый контрол
'пример аргументов:
'LoadAction GridWidth:=25, _
'    Ctrl:=Text1, _
'    Count:=3, _
'    Property:="Text="
'LoadAction GridHeight:=3, _
'    Gaps:=1, _
'    Ctrl:=Label1(1), _
'    Property:="Autosize=1,Caption=Заголовок//Адрес//Логин//Пароль//Телефон//Почта"
'------Ввод списков
'LoadAction Move:=[Слева направо], _
'    GridWidth:=20, _
'    Ctrl:=Combo1, _
'    Property:="list=Красный\\Желтый\\Зеленый//100руб\\200руб\\300руб\\400руб,listindex=0"
 
    Dim i&, ii&, j&, jj&, a$(), aa$(), ar(), o As Object, oo As Object
    Dim s$, ss$, ind&, g&, sl&, st&, iii&, v, prop$()
    
    On Error Resume Next
    With SetCtr
        
        If Move <> -3 Then .Move = (Move Mod 4)
        If .Move < 0 Then For i = Ctrl.Ubound To 0 Step -1: Unload Ctrl(i): Next
    
        If GridWidth > 0 Then .GridWidth = GridWidth
        If GridHeight > 0 Then .GridHeight = GridHeight
        If StartLeft > 0 Then .StartLeft = StartLeft
        If StartTop > 0 Then .StartTop = StartTop
        If Gaps > -1 Then .Gaps = Gaps
        If Not Container Is Nothing Then Set .Container = Container
    
        g = (Grid * Abs(.Gaps))
        Set o = Ctrl(Ctrl.Ubound)
        If Err Then
            Load Ctrl: Set o = Ctrl: Set Ctrl = Ctrl.Parent.Controls(Ctrl.Name)
            Dic(o.Name & o.Parent.hwnd) = o.Index - 1
        Else: ind = 0
        End If
 
        If Dic.Exists(o.Name & o.Parent.hwnd) Then
            ind = Dic(o.Name & o.Parent.hwnd) + 1
            Load Ctrl(ind)
            Set o = Ctrl(ind)
        End If
 
        Dic(o.Name & o.Parent.hwnd) = ind
        If Not .Container Is Nothing Then Set o.Container = .Container
        
        With o.Container
            If Not Dic.Exists(.hwnd) Then
                Dic(.hwnd) = Array(0, 0, 0, 0, 0, 0, 2, 2)
            End If
            ll = Dic(.hwnd)(0)
            tt = Dic(.hwnd)(1)
            ww = Dic(.hwnd)(2)
            hh = Dic(.hwnd)(3)
            mL = Dic(.hwnd)(4)
            mT = Dic(.hwnd)(5)
            SetCtr.StartLeft = IIf(SetCtr.StartLeft, SetCtr.StartLeft, Dic(.hwnd)(6))
            SetCtr.StartTop = IIf(SetCtr.StartTop, SetCtr.StartTop, Dic(.hwnd)(7))
        End With
    End With
    With o
        Select Case SetCtr.Move
        Case 0
            ll = mL + Grid: tt = Grid
        Case 1
            tt = mT + Grid: ll = Grid
        End Select
 
        With SetCtr
            sl = (.StartLeft * Grid): If ll < sl Then ll = ll + sl
            st = (.StartTop * Grid): If tt < st Then tt = tt + st
        End With
    End With
    With SetCtr
        If .GridWidth > 0 Then ww = Grid * .GridWidth
        If .GridHeight > 0 Then hh = Grid * .GridHeight
    End With
    '
    'Разбивка на комманды
    '
    prop = SplitSpec(Property, ",")
    For i = 0 To UBound(prop): ii = UBound(SplitSpec(prop(i))):  Do While ii > jj: jj = ii: Exit Do: Loop: Next
    ii = i - 1: If Count > 0 Then If (Count - 1) > jj Then jj = (Count - 1)
    
    ReDim Preserve ar(ii, jj)
    For i = 0 To UBound(prop)
        a = SplitSpec(prop(i), "=")
        aa = SplitSpec(a(1), "//")
        For j = 0 To jj
            s = aa(j): ar(i, j) = a(0) & "=" & s
        Next
    Next
 
    
    For j = 0 To jj
        Load Ctrl(ind + j)
        Set o = Ctrl(ind + j)
        With SetCtr
            If Not .Container Is Nothing Then Set o.Container = .Container
        End With
        
        With o
            .Move ll, tt: .Width = ww: .Height = hh: .Visible = 1
            For i = 0 To ii
                Set oo = o
                Do: a = SplitSpec(ar(i, j), "=", 2): iii = -1: iii = UBound(a)
                    If iii < 0 Then
                        Exit Do
                    ElseIf InStr(1, a(0), ".") Then
                        aa = SplitSpec(a(0), ".", 2)
                        Set oo = CallByName(oo, aa(0), VbGet)
                        ar(i, j) = aa(1) & "=" & a(1)
                    ElseIf a(0) = "List" Then
                        For Each v In SplitSpec(a(1), ""): oo.AddItem v: Next
                        Exit Do
                    Else: CallByName oo, a(0), VbLet, a(1): Exit Do
                    End If
                Loop
            Next
            If SetCtr.Move >= 0 Then
                If (ll + .Width) > mL Then mL = (ll + .Width)
                If (tt + .Height) > mT Then mT = (tt + .Height)
                With SetCtr
                    Select Case .Move Mod 2
                    Case 0: tt = tt + hh + g
                    Case 1: ll = ll + ww + g
                    End Select
                End With
            End If
            Dic(.Container.hwnd) = Array(ll, tt, ww, hh, mL, mT, SetCtr.StartLeft, SetCtr.StartTop)
            Dic(o.Name & o.Parent.hwnd) = ind + j
        End With
    Next
    SetCtr.StartLeft = 0: SetCtr.StartTop = 0
    
End Sub
 
 
Sub ControlsEnabled(Parent As Object, ByVal Enabled As Boolean, ParamArray Ctrls())
    'Включает/Отключает контролы
    'Примеры Ctrls:= Label1, "text1","text2(3 to 5,7)"
 
    Dim i&, ii&, j&, a1$(), a2$(), a3$(), a4$(), ctr As Object
    Dim ar$(), ind&, ubn&
 
    On Error Resume Next
    ReDim Preserve a1(UBound(Ctrls))
    For i = 0 To UBound(a1)
        If TypeName(Ctrls(i)) = "String" Then
            a1(i) = Ctrls(i)
        ElseIf IsObject(Ctrls(i)) Then
            a1(i) = Ctrls(i).Name
            a1(i) = a1(i) & "(" & Ctrls(i).Index & ")"
        End If
    Next
    For i = 0 To UBound(a1)
        a1(i) = Trim(a1(i))
        While InStr(1, a1(i), "  "): a1(i) = Replace(a1(i), "  ", " "): Wend
        If Len(a1(i)) Then a1(j) = a1(i): j = j + 1
    Next
    ReDim Preserve a1(j - 1)
    ubn = -1
    For i = 0 To UBound(a1)
        a2 = Split(a1(i), "("): a2(0) = Trim$(a2(0))
        If UBound(a2) > 0 Then
            a2(1) = Split(a2(1), ")")(0)
            a3 = Split(a2(1), ",")
            ReDim Preserve a2(UBound(a3) + 1)
            For ii = 1 To UBound(a2)
                a2(ii) = Trim$(a3(ii - 1))
                a4 = Split(a2(ii), "to", , 1)
                If UBound(a4) > 0 Then
                    For j = a4(0) To a4(1)
                        GoSub Preserve_ar
                        ar(ind) = a2(0) & "(" & j & ")": ind = ind + 1
                    Next
                Else: GoSub Preserve_ar
                    ar(ind) = a2(0) & "(" & a2(ii) & ")": ind = ind + 1
                End If
            Next
        Else: GoSub Preserve_ar: ar(ind) = a2(0): ind = ind + 1
        End If
    Next
    ReDim Preserve ar(ind - 1)
    For i = 0 To UBound(ar)
        If InStr(1, ar(i), "(") = 0 Then
            Set ctr = CallByName(Parent, ar(i), VbGet)
        Else
            a2 = Split(ar(i), "("): a2(1) = Split(a2(1), ")")(0)
            Set ctr = CallByName(Parent, a2(0), VbGet, a2(1))
        End If
        ctr.Enabled = Enabled
    Next
    
    Exit Sub
Preserve_ar:
    If ind > ubn Then ubn = (ind + 1) * 2: ReDim Preserve ar(ubn)
    Return
End Sub
Property Get ShellApp() As Object
    If mShellApp Is Nothing Then Set mShellApp = CreateObject("Shell.Application")
    Set ShellApp = mShellApp
End Property
 
Function NameIndex(ByVal ctr As Object) As String
    On Error Resume Next
    NameIndex = ctr.Name
    NameIndex = NameIndex & "(" & ctr.Index & ")"
End Function
 
Sub qSortList(ByVal List As Object, ByVal mn As Long, ByVal mx As Long)
    'Быстрая сортировка объектов List
    Dim i&, ii&, j$, jj$, id&
    With List
        i = mn: ii = mx: j = .List((i + ii) \ 2)
        Do Until i > ii: Do While .List(i) < j: i = i + 1: Loop: Do While .List(ii) > j: ii = ii - 1: Loop
            If (i <= ii) Then jj = .List(i): id = .ItemData(i): .List(i) = .List(ii): .ItemData(i) = .ItemData(ii): .List(ii) = jj: .ItemData(ii) = id: i = i + 1: ii = ii - 1
        Loop
    End With
    If mn < ii Then qSortList List, mn, ii
    If i < mx Then qSortList List, i, mx
End Sub
 
Sub qSort(Arr, ByVal mn As Long, ByVal mx As Long)
    'Быстрая сортировка
    Dim i As Long, l As Long, j As String, s As String
    i = mn: l = mx: j = Arr((i + l) \ 2)
    Do Until i > l: Do While Arr(i) < j: i = i + 1: Loop: Do While Arr(l) > j: l = l - 1: Loop
        If (i <= l) Then s = Arr(i): Arr(i) = Arr(l): Arr(l) = s: i = i + 1: l = l - 1
    Loop
    If mn < l Then qSort Arr, mn, l
    If i < mx Then qSort Arr, i, mx
End Sub
 
Sub ApplyFinalSize(ByVal obj As Object)
    'Применение конечного размера к форме или другому контейнеру
    Dim sW&, sH&
    On Error Resume Next
    With obj
        sW = .ScaleWidth
        sH = .ScaleHeight
        If sW > 0 Then sW = .Width - sW
        If sH > 0 Then sH = .Height - sH
        .Width = Dic(.hwnd)(4) + sW + Grid * 2
        .Height = Dic(.hwnd)(5) + sH + Grid * 2
    End With
End Sub
 
Property Get Dic() As Object
    If mDic Is Nothing Then Set mDic = CreateObject("scripting.dictionary"): mDic.CompareMode = 1
    Set Dic = mDic
End Property
 
Sub FrameRePaint(Parent As Object, Optional ByVal Frame As Object): Const ii = 9, ll = 45: Static i&, v, w, d As Object, j(ii) As Object: On Error GoTo g5: Do While j(ii) Is Nothing: Set j(ii) = Parent.Controls.Add("vb.label", "label_autosize"): j(ii).AutoSize = 1: Exit Do: Loop: Do While d Is Nothing: Set d = CreateObject("scripting.dictionary"): d.CompareMode = 1: Exit Do: Loop: Do Until Frame Is Nothing: Set v = Frame:  GoTo g1: Exit Do: Loop: For Each v In Parent.Controls
g1:     Do While TypeName(v) = "Frame": On d(v.hwnd) GoTo g2, g4: d(v.hwnd) = 1: Set j(0) = Parent.Controls.Add("vb.picturebox", "pic" & v.hwnd & 0, v): j(0).Visible = 1: j(0).BorderStyle = 0: For i = 1 To ii - 1: Do While i < 5: Set j(i) = Parent.Controls.Add("vb.picturebox", "pic" & v.hwnd & i, j(0)): j(i).Visible = 1: j(i).BorderStyle = 0: Exit Do: Loop: Do While i >= 5: Set j(i) = Parent.Controls.Add("vb.frame", "fra" & v.hwnd & i, j(i - 4)): j(i).Visible = 1: d(j(i).hwnd) = 2: Exit Do: Loop: Next: For Each w In Parent.Controls: Do While w.Container.hwnd = v.hwnd And w.Name <> j(0).Name: Set w.Container = j(0): Exit Do: Loop: Next: GoTo g3
g2:         For i = 0 To ii - 1: Do While i < 5: Set j(i) = Parent.Controls("pic" & v.hwnd & i): Exit Do: Loop: Do While i >= 5: Set j(i) = Parent.Controls("fra" & v.hwnd & i): Exit Do: Loop: Next
g3:         With v: Set j(ii).Font = .Font: j(ii).Caption = .Caption: For i = 0 To ii - 1: Select Case i
                        Case 0: j(i).Move 0, 0, .Width, .Height
                        Case 1: j(i).Move 0, 0, .Width, j(ii).Height
                        Case 2: j(i).Move 0, 0, ll, .Height
                        Case 3: j(i).Move .Width - ll, 0, ll, .Height
                        Case 4: j(i).Move 0, .Height - ll, .Width, ll
                        Case 5: j(i).Move 0, 0, .Width, .Height: Set j(i).Font = .Font: j(i).Caption = .Caption
                        Case 6: j(i).Move 0, 0, .Width, .Height
                        Case 7: j(i).Move -.Width + ll, 0, .Width, .Height
                        Case 8: j(i).Move 0, -.Height + ll, .Width, .Height
                    End Select: If i = 0 Or i > 4 Then j(i).BackColor = .BackColor
                Next: End With: Exit Do: Loop
g4: Next
g5: End Sub
 
 
Public Function SplitSpec(ByVal Str As String, Optional ByVal Delimiter$ = "//", _
Optional ByVal Limit& = -1, Optional ByVal Comp As VbCompareMethod) As String()
    Static i&, a$()
    a = Split(Str, Delimiter, Limit, Comp)
    For i = 0 To UBound(a): a(i) = Trim$(a(i)): Next
    SplitSpec = a
End Function
fever brain
Экстрасенс
726 / 264 / 63
Регистрация: 05.01.2016
Сообщений: 762
Записей в блоге: 3
30.09.2016, 19:18     Готовые решения и полезные коды на Visual Basic 6.0 #176
форма:

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
Option Explicit
Option Compare Text
 
Const fxPas& = 7 'Число знаков пароля
Private Type TRecord
    Title As String
    Address  As String
    Login As String
    Password As String
    Phone As StringA
    Mail As String
    id As Long
End Type
 
Private Type TRec
    Ubound As Long
    CurInd  As Long
    NewId  As Long
    Records() As TRecord
End Type
 
Private Const rr = vbLf & vbCrLf
 
Dim mRec As TRec, mRecNull As TRec, FileRec$, FileRecCopy$, v
Dim i&, j&, ff&, s$, DataChanges As Boolean
 
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (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 m_hMod As Long
 
Private Sub Form_Load()
 
    ''    s = ""
    ''    For i = 33 To 255
    ''        s = s & Chr(i)
    ''        If i Mod 32 = 0 Then s = s & vbLf
    ''    Next
    ''    Clipboard.Clear
    ''    Clipboard.SetText s
 
    On Error Resume Next
    FileRec = Environ("AppData") & "\Accounts"
    FileRecCopy = FileRec & "\Accounts.bak"
    MkDir FileRec
    FileRec = FileRec & "\Accounts.dat"
 
    
    Me.Caption = "Аккаунты"
    
    LoadAction GridHeight:=3, _
        Gaps:=1, _
        Ctrl:=Label1, _
        Property:="Autosize=1,Caption=Заголовок//Адрес//Логин//Пароль//Телефон//Почта"
    
    LoadAction GridWidth:=25, _
        Ctrl:=Text1, _
        Count:=Label1.Count, _
        Property:="Text="
    
    LoadAction GridWidth:=3, _
        GridHeight:=3, _
        Ctrl:=Command1(10), _
        Count:=Label1.Count, _
        Property:="caption=}//Ђ//},font.name=Wingdings 3,ToolTipText=Копировать//Выбрать//Копировать"
    
    LoadAction GridWidth:=25, _
        GridHeight:=3, _
        Ctrl:=Text1
    
    LoadAction Move:=[Продолжить вниз], _
        GridWidth:=25, _
        GridHeight:=(Label1.Count - 1) * 4, _
        Ctrl:=List1
 
    LoadAction Move:=[Сверху вниз], _
        GridWidth:=3, _
        GridHeight:=3, _
        Ctrl:=Command1, _
        Property:="caption=У,font.name=Wingdings 2,font.size=10,ToolTipText=Очистить поиск"
 
    LoadAction Move:=[Продолжить вниз], _
        GridWidth:=3, _
        GridHeight:=3, _
        Gaps:=0, _
        Ctrl:=Command1(20), _
        Property:="caption=З//И,font.name=Wingdings 3,ToolTipText=Переместить вверх//Переместить вниз"
    
    LoadAction Move:=[Слева направо], _
        GridWidth:=12, _
        GridHeight:=5, _
        Gaps:=1, _
        Ctrl:=Command1(30), _
        Property:="caption=Добавить запись//Удалить запись//Сортировать записи//Сохранить//Пере запуск"
    
    LoadAction Move:=[Продолжить вниз], _
        GridWidth:=3, _
        GridHeight:=3, _
        Ctrl:=Command1, _
        Property:="caption=Ђ,font.name=Wingdings 3,ToolTipText=Дополнительно"
    
''''    LoadAction Move:=[Слева направо], _
''''        GridWidth:=20, _
''''        Ctrl:=Combo1, _
''''        Property:="list=Красный\\Желтый\\Зеленый//100руб\\200руб\\300руб\\400руб,listindex=0//1"
    
    
    LoadAccounts
    Command1_Click -1
    '    FrameRePaint Me
End Sub
 
 
 
Private Sub SubMenu_Click(Index As Integer)
    Const ss = "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789"
 
    Select Case NameIndex(ActiveControl)
    Case "command1(11)"
        Select Case Index
        Case 0: With Clipboard: .Clear: .SetText (Text1(1).Text): End With
        Case 1: ShellApp.Open Text1(1).Text
        End Select
    Case "command1(35)"
        Select Case Index
        Case 0 'Создать резервную копию
            If Len(Dir(FileRecCopy)) > 0 Then
                If MsgBox("Копия уже существует переписать ?", 68) = vbNo Then Exit Sub
            End If
            Command1_Click 33
            FileCopy FileRec, FileRecCopy
            
        Case 1 'Восстановить из копии
            Kill FileRec
            FileCopy FileRecCopy, FileRec
            Command1_Click 34
        Case 2 'Генерация пароля
            s = Space$(fxPas): Randomize Timer
            Mid$(s, 1, 1) = Mid$(ss, Fix(Rnd * 52) + 1, 1)
            For i = 2 To fxPas
                Mid$(s, i, 1) = Mid$(ss, Fix(Rnd * 62) + 1, 1)
            Next
            Text1(3).Text = s
            mRec.Records(mRec.CurInd).Password = s
        End Select
    End Select
End Sub
 
Private Sub SavingAccounts()
    'Сохранение всех записей
    Dim Rec2() As TRecord, i&, j&
    If ActiveControl.Name = "Text1" Then Text1_Validate ActiveControl.Index, 0
    Rec2 = mRec.Records
    For i = 0 To List1(0).ListCount - 1: For j = 0 To UBound(Rec2)
        With Rec2(j)
            If .id = List1(0).ItemData(i) Then
                mRec.Records(i) = Rec2(j)
            End If
        End With
    Next: Next
    On Error Resume Next
    Kill FileRec
    ff = FreeFile
    Open FileRec For Binary As #ff
    Put #ff, 1, mRec
    Close #ff
    DataChanges = 0 ' Сброс изменений
End Sub
 
 
Private Sub Text1_Change(Index As Integer)
    Dim i&, j&, s$, a$(), fnd&
    Static ar$(), b As Boolean
    DataChanges = True 'Изменения в режиме выполнения
    With Text1(Index)
        Select Case Index
        Case 1
            s = Trim(.Text)
            .FontUnderline = IIf(Left$(s, 6) = "ftp://", 1, 0)
            .FontUnderline = IIf(Left$(s, 7) = "http://", 1, .FontUnderline)
            .FontUnderline = IIf(Left$(s, 8) = "https://", 1, .FontUnderline)
            .FontUnderline = IIf(InStr(1, s, " ") = 0, .FontUnderline, 0)
            .ForeColor = IIf(.FontUnderline, vbBlue, vbBlack)
        Case 6
            With List1(0)
                If b = False Then
                    b = True
                    ReDim Preserve ar(.ListCount - 1)
                    For i = 0 To UBound(ar)
                        ar(i) = .List(i) & rr & .ItemData(i)
                    Next
                End If
            End With
            ControlsEnabled Me, .Text = "", "Command1(20,21,30 to 33)"
            If .Text = "" Then b = False
            List1(0).Clear
            For i = 0 To UBound(ar)
                a = Split(ar(i), rr)
                If InStr(1, a(0), .Text, 1) > 0 Or .Text = "" Then
                    List1(0).AddItem a(0), j
                    List1(0).ItemData(j) = a(1)
                    If a(1) = mRec.Records(mRec.CurInd).id Then fnd& = j
                    j = j + 1
                End If
            Next
            With List1(0)
                ControlsEnabled Me, .ListCount > 0, "List1(0)", "Label1(0 to 5)", "Text1(0 to 5)", "Command1(10 to 15)"
                If .ListCount > 0 Then .ListIndex = fnd
            End With
        End Select
    End With
End Sub
 
 
Private Sub LoadAccounts()
    On Error Resume Next
    ff = FreeFile
    Open FileRec For Binary As #ff
    If LOF(ff) < 1 Then
        mRec.Ubound = -1
    Else
        Get #ff, 1, mRec
    End If
    Close #ff
    List1(0).Clear
    For i = 0 To mRec.Ubound
        With mRec.Records(i)
            List1(0).AddItem .Title, i
            List1(0).ItemData(i) = .id
        End With
    Next
    List1(0).ListIndex = 0
    DataChanges = 0 'Сброс изменений
End Sub
 
 
Private Sub Text1_Validate(Index As Integer, Cancel As Boolean)
    On Error Resume Next
    With mRec.Records(mRec.CurInd)
        
        Select Case Index
        Case 0
            If Trim(Text1(Index).Text) = "" Then
                MsgBox Label1(Index) & " не должен быть пустым", vbExclamation, Me.Caption
                Text1(Index).Text = .Title
                Cancel = 1: Exit Sub
            End If
            .Title = Text1(Index)
            With List1(0)
                .List(.ListIndex) = Text1(Index)
            End With
            
        Case 1
            .Address = Text1(Index)
        Case 2
            .Login = Text1(Index)
        Case 3
            .Password = Text1(Index)
        Case 4
            With Text1(Index)
                s = "" 'Форматируем номер телефона
                For i = 1 To Len(.Text): If Mid$(.Text, i, 1) Like "#" Then s = s & Mid$(.Text, i, 1)
                Next: s = Format(s, IIf(Len(s) < 8, "###-##-##", "# (###) ###-##-##"))
                While Left$(s, 1) = "-": s = Mid$(s, 2): Wend: .Text = s
            End With
            .Phone = Text1(Index)
        Case 5
            .Mail = Text1(Index)
        End Select
    End With
End Sub
 
Private Sub List1_Click(Index As Integer)
    Dim i&
    With mRec
        On Error Resume Next
        For i = 0 To mRec.Ubound
            With .Records(i)
                If .id = List1(Index).ItemData(List1(Index).ListIndex) Then
                    mRec.CurInd = i
                    Text1(0) = .Title
                    Text1(1) = .Address
                    Text1(2) = .Login
                    Text1(3) = .Password
                    Text1(4) = .Phone
                    Text1(5) = .Mail
                    Exit For
                End If
            End With
        Next
    End With
    DataChanges = False
End Sub
 
 
Private Sub Command1_Click(Index As Integer)
    Dim i&, j&, a$(), aa$()
    
    Select Case Index
    Case -1 'Если кнопка не выбранна, и нужно попасть в конец процедуры
    Case 35
        LoadAction Move:=[Новые пункты], _
            Ctrl:=SubMenu, _
            Property:="enabled=1//" & Abs(Len(Dir(FileRecCopy)) > 0) & ",caption=Создать резервную копию//Восстановить из копии//Сгенерировать пароль"
        With Command1(Index): PopupMenu Menu, , .Left, .Top: End With
        
    Case 34: 'Перезагрузка
        Command1_Click 16 'Стирание поля над списком
        mRec = mRecNull 'Полное Обнуление
        LoadAccounts
    Case 33:  SavingAccounts 'Сохранение всех записей
 
    Case 16: Text1(Index - 10).Text = "" 'Стирание поля над списком
    Case 14 'Копировать телефон
        With Text1(Index - 10): s = ""
            For i = 1 To Len(.Text): If Mid$(.Text, i, 1) Like "#" Then s = s & Mid$(.Text, i, 1)
        Next: End With: With Clipboard: .Clear: .SetText s: End With
    Case 11
        With Text1(1)
            LoadAction Move:=[Новые пункты], _
                Ctrl:=SubMenu, _
                Property:="enabled=1//" & Abs(.FontUnderline) & ",caption=Копировать//Перейти по ссылке"
        End With
        With Command1(Index): PopupMenu Menu, , .Left, .Top: End With
    Case 10 To 15 'Копировать поля
        With Clipboard: .Clear: .SetText (Text1(Index - 10).Text): End With
    Case 32 'Сортировка
        With List1(0)
            qSortList List1(0), 0, .ListCount - 1
            .ListIndex = 0
        End With
        DataChanges = 1
    Case 20, 21 'Перемещение в списке
        With List1(0)
            i = IIf(Index = 20, -1, 1)
            j = i + .ListIndex
            If j >= .ListCount Or j < 0 Then Exit Sub
            v = Array(.List(j), .ItemData(j))
            .RemoveItem (.ListIndex + i)
            j = .ListIndex + Abs(i < 0)
            .AddItem v(0), (j)
            .ItemData(j) = v(1)
        End With
        DataChanges = 1
    Case 31 'Удалить
        With mRec
            .Ubound = .Ubound - 1
            If .Ubound < 0 Then
                Erase .Records
                List1(0).Clear
                For i = 0 To Text1.Count - 1: Text1(i).Text = "": Next
                .Ubound = -1
                .NewId = 0
            Else
                ReDim Rec2(.Ubound) As TRecord
                For i = 0 To .Ubound
                    With .Records(i)
                        If .id <> List1(0).ItemData(List1(0).ListIndex) Then
                            Rec2(j) = mRec.Records(i): j = j + 1
                        End If
                    End With
                Next
                .Records = Rec2
                With List1(0)
                    j = .ListIndex
                    .RemoveItem .ListIndex
                    .ListIndex = j - Abs(j = .ListCount)
                End With
            End If
        End With
    Case 30 'Добавить
        With mRec
            .Ubound = .Ubound + 1
            ReDim Preserve .Records(.Ubound)
            With .Records(.Ubound)
                mRec.NewId = mRec.NewId + 1
                .id = mRec.NewId
                .Title = "Новая запись " & .id
                List1(0).AddItem .Title, 0
                List1(0).ItemData(0) = .id
            End With
            List1(0).ListIndex = 0
        End With
    Case Else 'Если это непроработанная кнопка выход здесь
        Exit Sub
    End Select
    
    ControlsEnabled Me, List1(0).ListCount > 0, "List1(0)", "Label1(0 to 5)", "Text1(0 to 6)", "Command1(10 to 16, 20,21 , 31 to 32)"
    
End Sub
 
 
 
 
Private Sub Form_Resize()
    If Me.WindowState <> 1 Then Me.WindowState = 0
    ApplyFinalSize Me
End Sub
 
Private Sub Form_Paint()
    'Поверх всех окон
    SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, &H10 Or &H1 Or &H2
End Sub
 
Private Sub Form_Initialize()
    m_hMod = LoadLibrary("shell32.dll")
    InitCommonControls
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    If DataChanges Then
        If MsgBox("Сохранить изменения ?", 68, Me.Caption) = vbYes Then SavingAccounts
    End If
    FreeLibrary m_hMod
End Sub
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Аккаунты.rar (95.7 Кб, 11 просмотров)
Pro_grammer
Модератор
5858 / 2018 / 385
Регистрация: 24.04.2011
Сообщений: 3,429
Записей в блоге: 9
01.10.2016, 06:55     Готовые решения и полезные коды на Visual Basic 6.0 #177
Цитата Сообщение от fever brain Посмотреть сообщение
Хранение настроек находиться всегда в AppPath\User и тд тоесть норм. ВС сохранит ваши записи (проверял)
Записи такого рода без шифрования хранить категорически не рекомендую! Написать троян, который утащит этот файл - за 5 минут.
И "Пере запуск" надо бы исправить. А то перед Ксюшей неудобно
fever brain
Экстрасенс
726 / 264 / 63
Регистрация: 05.01.2016
Сообщений: 762
Записей в блоге: 3
03.10.2016, 16:24     Готовые решения и полезные коды на Visual Basic 6.0 #178
Можно и зашифровать записи, сделать это достаточно легко
с помощью генератора случайных чисел.
Дело в том, что если указать для генерации стартовое число то последовательность будет повторяться
в моём следуещем примере всё так и сделанно, разумеется я не стану показывать как у меня это реализованно
но с большой радостью выложу алгоритм шифрования, на основе выше сказанного
в этом алгоритме если изменить константы генераций, то уже никто не сможет это прочесть
кроме той программы которая этот файл сохранила

Шифрование записей

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
Option Explicit
 
Const r = 123 'Старт генерации подставных знаков
Const tt = 100 'Число различных знаков в массиве
 
Dim WithEvents tx As TextBox, s$, i&, l&, b(tt) As Byte
Dim fso
 
Private Sub Form_Load()
    Set tx = Controls.Add("vb.Textbox", "tx"):  tx.Visible = 1
    Caption = "Хранение секретной записи"
    ChDir App.Path
    
    Set fso = CreateObject("scripting.filesystemobject")
    
    'Создаём байтовую запись из множества (tt) различных символов со стартом генерации значения (r)
    
    Randomize r
    For i = 0 To UBound(b): b(i Mod tt) = Fix(Rnd * 256): Next
    With fso
        If .FileExists("1.txt") Then
            With .OpenTextFile("1.txt")
                s = .ReadAll
                'Дешифруем заданный текст
                For i = 1 To Len(s): Mid$(s, i, 1) = Chr((Asc(Mid$(s, i, 1)) + b(i Mod tt)) Mod 256): Next
                tx = s
            End With
        Else: tx = "Здесь вы можете хранить секретики ))"
        End If
    End With
End Sub
 
Private Sub Form_Resize()
    tx.Move 0, 0, ScaleWidth
    With Me
        .Height = (.Height - .ScaleHeight) + tx.Height
    End With
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    With fso.CreateTextFile("1.txt")
        s = tx
        For i = 1 To Len(s) 'шифруем заданный текст и сохраняем его в засекреченном виде
            l = Asc(Mid$(s, i, 1)) - b(i Mod tt)
            If l < 0 Then l = (l + 512) Mod 256
            Mid$(s, i, 1) = Chr(l)
        Next
        .Write s
    End With
End Sub
на картинке ниже, показанно как выглядет в программе и как это выглядет
в блокноте, тоесть в каком виде эта инфа храниться
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Pro_grammer
Модератор
5858 / 2018 / 385
Регистрация: 24.04.2011
Сообщений: 3,429
Записей в блоге: 9
03.10.2016, 21:03     Готовые решения и полезные коды на Visual Basic 6.0 #179
Цитата Сообщение от fever brain Посмотреть сообщение
то уже никто не сможет это прочесть
кроме той программы которая этот файл сохранила

Скажем так, на прочтение такой шифровки потребуется секунд на 20 больше времени, чем не шифрованного текста.
Но в любом случае уже лучше, чем ничего!
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
05.12.2016, 19:48     Готовые решения и полезные коды на 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

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

Или воспользуйтесь поиском по форуму:
admike
0 / 0 / 0
Регистрация: 05.12.2016
Сообщений: 1
05.12.2016, 19:48     Готовые решения и полезные коды на Visual Basic 6.0 #180
Больше недели бился над программой вычисления определителя матрицы через разложение по строке на visual basic. Вот результат:
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
Sub main()
  n = Val(InputBox("n"))
  If n < 2 Then
    n = 2
  End If
  ReDim A(n, n)
  For i = 1 To n
    For j = 1 To n
      A(i, j) = Val(InputBox("Enter A" & i & j))
    Next
  Next
  r = DetA(n, A)
  MsgBox r
End Sub
Function DetA(n, A())
If n = 2 Then
  S = A(1, 1) * A(2, 2) - A(1, 2) * A(2, 1)
Else
  ReDim B(n - 1, n - 1)
  For i = 1 To n
    Call Minor(i, n, A, B)
    S = S + (-1) ^ (i + 1) * A(1, i) * DetA(n - 1, B)
  Next
End If
DetA = S
End Function
Function Minor(m, n, A(), B())
  For i = 2 To n
    For j = 1 To n
      If j < m Then
        B(i - 1, j) = A(i, j)
      Else
        If j > m Then
          B(i - 1, j - 1) = A(i, j)
        End If
      End If
    Next
  Next
End Function
Надеюсь, кому-нибудь пригодится.
Yandex
Объявления
05.12.2016, 19:48     Готовые решения и полезные коды на Visual Basic 6.0
Ответ Создать тему
Опции темы

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