Форум программистов, компьютерный форум, киберфорум
Наши страницы

Visual Basic

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
Dragokas
Эксперт WindowsАвтор FAQ
16042 / 6860 / 826
Регистрация: 25.12.2011
Сообщений: 10,613
Записей в блоге: 16
19.01.2017, 01:34  [ТС] #196
[CMD] Авто-сборщик ресурса из нескольких файлов

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

Это обновлённая версия батника (запчасть от Авто-компилятора).

Как пользоваться?
Скинуть батник в папку с проектом и запустить. Всё.
Но, сперва нужно всё настроить.

Как настроить?

При первом использовании, Вы должны вручную в IDE зайти в Add-Ins, подключить Resource Editor.
Зайти в Tools -> Resource Editor -> Подключить любой файл к проекту и сохранить ресурс под именем RESOURCE.res в корневой папке проекта.

Затем отредактировать батник:
У меня в примере там такие строки:
set Res[1]=1 #24 manifest.txt
set Res[2]=101 CUSTOM TasksWhite.csv
set Res[3]=102 CUSTOM MSCOMCTL.OCX.bak
set Res[4]=103 CUSTOM readme - History.txt
set Res[5]=201 CUSTOM _Lang_EN.lng
set Res[6]=202 CUSTOM _Lang_RU.lng
Это пример. Удалите их все и создайте свои так, как вам нужно.
set Res[1] - это служебный номер (должны идти по порядку).
дальше после = номер ресурса, тип ресурса, имя файла, лежащего рядом с программой, который нужно добавить в ресурс.

В примере выше у меня автоматом подключается манифест.
Всего ресурсов не больше 10. Если нужно больше, поправьте дважды такую строку:
Windows Batch file
1
For /L %%C in (1 1 10) do (
Сохраните, всё готово.

Замечание: Код несовместим с портативными версиями VB6. Если нужна портативность, замените эту часть:
"%PF%\Microsoft Visual Studio\VB98\Wizards\rc.exe"
на путь к rc.exe (допускается относительный путь)

Код батника _1_Update_Resource.cmd

Windows Batch file
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
@echo off
SetLocal EnableExtensions EnableDelayedExpansion
 
:: help info on [url]http://www.vbaccelerator.com/home/VB/Code/Libraries/Resources/Using_RC_EXE/article.asp[/url]
 
echo.
echo :: Creating resource file
echo.
 
Call :GetOSBitness OSBitness
if "%OSBitness%"=="x32" (set "PF=%ProgramFiles%") else (set "PF=%ProgramFiles(x86)%")
cd /d "%~dp0"
 
set Res[1]=1 #24 manifest.txt
set Res[2]=101 CUSTOM TasksWhite.csv
set Res[3]=102 CUSTOM MSCOMCTL.OCX.bak
set Res[4]=103 CUSTOM readme - History.txt
set Res[5]=201 CUSTOM _Lang_EN.lng
set Res[6]=202 CUSTOM _Lang_RU.lng
 
2>NUL del /f /a 1.RC
 
For /L %%C in (1 1 10) do (
  if defined Res[%%C] (
    for /f "tokens=1-2*" %%a in ("!Res[%%C]!") do (
      set "ID=%%a"
      set "type=%%b"
      set "file=%%c"
      >NUL copy /y "!file!" "!file!.tmp" || (
        echo Error occured during creation resource from: "!file!.tmp"
        pause
      )
      echo !ID! !type! LOADONCALL DISCARDABLE "!file!.tmp">> 1.RC
    )
  )
)
 
2>nul del /f /a RESOURCE.res
 
"%PF%\Microsoft Visual Studio\VB98\Wizards\rc.exe" /r /v /fo RESOURCE.res 1.RC && (
    echo.& echo -------   SUCCESS
) || (
    echo Error occured during creation resource from: 1.RC
    pause
)
 
:: Clear
For /L %%C in (1 1 10) do (
  if defined Res[%%C] (
    for /f "tokens=1-2*" %%a in ("!Res[%%C]!") do (
      >NUL del "%%c.tmp"
    )
  )
)
2>NUL del /f /a 1.RC
 
exit /b
 
:GetOSBitness
  set "xOS=x64"& If "%PROCESSOR_ARCHITECTURE%"=="x86" If Not Defined PROCESSOR_ARCHITEW6432 set "xOS=x32"
  set "%~1=%xOS%"
Exit /B
3
Вложения
Тип файла: zip _1_Update_Resource.zip (961 байт, 5 просмотров)
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
19.01.2017, 01:34
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Готовые решения и полезные коды на Visual Basic 6.0 (VB):

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

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

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

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

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

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

219
Dragokas
Эксперт WindowsАвтор FAQ
16042 / 6860 / 826
Регистрация: 25.12.2011
Сообщений: 10,613
Записей в блоге: 16
19.01.2017, 03:04  [ТС] #197
Разблокировка прав на ключи реестра

Этот модуль позволяет снять любые уровни запрета на доступ к ключам реестра (за исключением активной блокировки другим процессом или драйвером и специфическими маскировками, вроде Null).

Сфера применения:
Может использоваться для получения доступа к разделам, защищенных правами LOCAL SYSTEM.
Также позволяет восстановить права для разделов служб (например, при устранении последствий заражения ZeroAcess/Sirefef).

Механизм

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

SID | Rights | Inheritance | OS / Path

1. Local System:F (OI)(CI)
2. Administrators:F (OI)(CI)
3. Service alias :F (OI)(CI) (optional) - только для подразделов в HKLM\SYSTEM\CurrentControlSet\services\
4. Trusted Installer:F (OI)(CI) (optional) (Vista+)
5. AppX:R - Все пакеты приложений (OI)(CI) (optional) (Win 8.0+)

Только для HKCU:
6. Users:F (OI)(CI)
7. Restricted:R (OI)(CI)

Только для не HKCU:
6. Creator:F (CI)
7. Users:R (OI)(CI)
8. PowerUsers:R (OI)(CI) (XP only)

Описание меток:
OI - применяется для этого раздела.
CI - применяется для подразделов.
F - полные права
R - права только на чтение (запрос значения, перечисление подразделов, уведомление, чтение разрешений).

Применение фикса не рекомендуется к очень большому количеству разделов (как например, корню (улью)). Это может существенно увеличить размер реестра и понизить производительность, т.к. отключается наследование. Для подобных операций лучше использовать другие программы, вроде SubInAcl, SetAcl, Windows Repair-all-in-one.

Всегда будьте предельно осторожны при работе с реестром. Делайте резервным копии!!! (например, через ERUNT)
Сброс привилегий некоторых ключей может привести к отказу в работе системы!!! Автор не отвечает за кривые руки пользователя.

Совместимость:
64-битные ключи поддерживаются.
Win XP-10.
2
Вложения
Тип файла: zip RegKeyUnlocker.zip (37.0 Кб, 7 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
16042 / 6860 / 826
Регистрация: 25.12.2011
Сообщений: 10,613
Записей в блоге: 16
22.01.2017, 23:49  [ТС] #198
[CMD] Поиск не-заэкранированных операторов STOP в исходном коде

Иногда бывает, что в релизную сборку случайно проскакивает STOP, который забыли удалить/заэкранировать.

К тому же, я например, часто использую оператор Stop внутри обработчика ошибок:
Visual Basic
1
2
3
ErrorHandler:
    ErrorMsg ..........
    If inIDE Then Stop: Resume Next
В таком ключе, в исходнике нереально найти утерянный Stop через Ctrl + F.

Этот батник нужно положить в папку с проектом и запустить.
Он сам просканирует файлы *.bas *.frm *.cls и если найдёт ошибку, выдаст:
строку с оператором Stop, номер строки, и имя модуля.

По-умолчанию игнорируется выражение "if inIDE Then Stop".
Если нужно добавить новые исключения, посмотрите, как это сделано рядом с ключевой фразой call :SkipKeyWords.
3
Вложения
Тип файла: zip Check_Stop_Statements.zip (665 байт, 5 просмотров)
fever brain
oh my god
822 / 398 / 78
Регистрация: 05.01.2016
Сообщений: 1,120
Записей в блоге: 7
17.02.2017, 07:16 #199
Еще раз здравствуйте, выкладываю очередную версию 2-1
радикально ничего не поменялось способы хранения те-же
добавилась кнопка в области редактирования с рисунком магиии
Так-же исправленн глюк при старте отображения окна

Не по теме:

Скучно без коментариев программера ))

0
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar Accounts2-1.rar (47.8 Кб, 10 просмотров)
fever brain
oh my god
822 / 398 / 78
Регистрация: 05.01.2016
Сообщений: 1,120
Записей в блоге: 7
17.02.2017, 07:39 #200
Пароль генерируется поверх старого, тоесть если раньше было 12345, то по нажатии этой кнопки будет

qwexc146d
12345

Делается это во избежании утери старого пароля, все продуманно еще в версии 2-0
считываеться только верхняя строчка без пробелов

Если программа будет жаловаться на то что не может найти модуль
то поместите эту длл в папку с программой, в версии 2-0 я уже выкладывал её...
0
Вложения
Тип файла: rar DLL.rar (772.5 Кб, 3 просмотров)
CharlyChaplin
164 / 15 / 1
Регистрация: 28.05.2015
Сообщений: 117
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 Кб, 11 просмотров)
fever brain
oh my god
822 / 398 / 78
Регистрация: 05.01.2016
Сообщений: 1,120
Записей в блоге: 7
01.05.2017, 17:07 #202
Калькулятор с функциями vb


2
Dragokas
Эксперт WindowsАвтор FAQ
16042 / 6860 / 826
Регистрация: 25.12.2011
Сообщений: 10,613
Записей в блоге: 16
24.06.2017, 23:43  [ТС] #203
Лучший ответ Сообщение было отмечено автором темы, экспертом или модератором как ответ
Регулярные выражения: обёртка для 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 Кб, 2 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
16042 / 6860 / 826
Регистрация: 25.12.2011
Сообщений: 10,613
Записей в блоге: 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
Модератор
7222 / 2454 / 743
Регистрация: 22.02.2013
Сообщений: 3,522
Записей в блоге: 74
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 Кб, 6 просмотров)
fever brain
oh my god
822 / 398 / 78
Регистрация: 05.01.2016
Сообщений: 1,120
Записей в блоге: 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 Кб, 10 просмотров)
CharlyChaplin
164 / 15 / 1
Регистрация: 28.05.2015
Сообщений: 117
31.07.2017, 08:58 #207
Таймер на автовыключение/перезагрузку/завершения сеанса с сохранением настроек в самой программе.

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

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

Вариант использования:
0.) Помещаем в Автозагрузку(меню Пуск)
1.) Запускаем в первый раз. Настраиваем. Закрываем(настройки сохраняются).
2.) Потом запускаем второй раз(окно уже невидимо) и время контролируется в зависимости от сделанных настроек. Время подошло - программа всплывает. Если нужно, чтобы окно всплыло - нажимаем комбинацию: "Ctrl(любой) + ЛКМ + ПКМ". После настроек её закрываем(она сохраняет) и заново запускаем. При желании можно свернуть в трей пока идёт отсчёт, предварительно настроенных, секунд.
2
Вложения
Тип файла: rar OffTimer.rar (460.4 Кб, 6 просмотров)
Catstail
Модератор
22838 / 11204 / 1812
Регистрация: 12.02.2012
Сообщений: 18,444
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
16042 / 6860 / 826
Регистрация: 25.12.2011
Сообщений: 10,613
Записей в блоге: 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 Мб, 6 просмотров)
fever brain
oh my god
822 / 398 / 78
Регистрация: 05.01.2016
Сообщений: 1,120
Записей в блоге: 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
1
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Изображения
 
04.09.2017, 22:02
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
04.09.2017, 22:02
Привет! Вот еще темы с ответами:

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

Отличия версий Visual Basic 6.0 от Visual Basic 6.5? - Visual Basic
У меня 3 вопроса: 1.Чем отличается версия Visual Basic 6.0 от Visual Basic 6.5? 2.Можно ли запустить проект созданный раннее в Visual...

Кто пишет программы в Visual Studio 2010 на Visual Basic? - Visual Basic
Кто пишет программы в Visual Studio 2010 на Visual Basic?

Проблема с установкой Visual Studio вообще и Visual Basic - Visual Basic
Точнее, с установкой Visual Studio вообще и Visual Basic в частности. В самом конце установки, при setup is updating your system,...


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

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

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