Готовые решения и полезные коды на Visual Basic 6.0 - VB - Страница 6

@The trick · 23.05.2014, 00:51

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

Салют

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
Option Explicit
 
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundW" (ByVal lpszName As Long, ByVal hModule As Long, ByVal dwFlags As Long) As Long
 
Private Const SND_ASYNC = &H1
Private Const pi = 3.14
 
Private Function Draw(v As Long, cc As Long) As Boolean
    Dim dh As Single, c As Single, d As Single, x As Single, y As Single, w As Long, i As Long, dx As Single, dy As Single, _
        gr As Single, r As Single, g As Single, b As Single, n As String
    Rnd v: cc = cc + 2
    If cc <= 0 Then
        Exit Function
    ElseIf cc <= 100 Then
        If cc = 2 Then n = App.Path & "\1.wav": PlaySound StrPtr(n), 0, SND_ASYNC
        dh = 100 / cc: x = Rnd * 0.75 + 0.125 + (cc * ((v And 2) - 1)) / 1000: y = Sin((cc - 2) / 200 * pi) * 0.75
        w = 21 - cc * 0.2: d = 255 / w: c = 0
        Do: c = 255 / w: DrawWidth = w: PSet (x, y), RGB(c, c, 0): w = w - 1: Loop While w
    ElseIf cc < 300 Then
        If cc = 102 Then n = App.Path & "\0.wav": PlaySound StrPtr(n), 0, SND_ASYNC
        dh = (cc - 100) / 200: gr = (1 - Cos(dh * pi * 0.25)) * dh: dx = Rnd * 0.75 + 0.125 + ((v And 2) - 1) / 10
        dy = 0.75 - gr: i = Rnd * 100 + 200: gr = 1 - 0.2 ^ (dh * 5): dh = 1 - dh
        r = Rnd * 0.8 + 0.2: g = Rnd * 0.8 + 0.2: b = Rnd * 0.8 + 0.2
        If cc < 150 Then
            b = (1 - (cc - 100) / 50) * 3
            For w = (cc - 100) * 2 To 1 Step -1
                DrawWidth = w * 5: c = cc / w * b: PSet (dx, dy), RGB(c * r, c * g, c * b)
            Next
        End If
        Do While i
            c = Rnd * pi * 2: d = gr * (Rnd * 0.8 + 0.2) * 0.5: x = Cos(c) * d + dx: y = Sin(c) * d + dy
            w = (dh * 6) * Abs(Sin((cc + i) / 10 * pi)) + 1: c = 0
            Do: c = 512 / w * dh: DrawWidth = w: PSet (x, y), RGB(c * r, c * g, c * b): w = w - 1: Loop While w
            i = i - 1
        Loop
    Else: Draw = True: cc = 0: v = v - Rnd * 100
    End If
End Function
Private Sub Form_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    Randomize
End Sub
Private Sub Form_Resize()
    Scale (0, 1)-(1, 0)
End Sub
Private Sub tmrTimer_Timer()
    Static a1 As Long, a2 As Long, c1 As Long, c2 As Long
    If a1 = 0 Then a1 = -(Rnd * 100) - 1: a2 = a1 - 2: c2 = -150
    Call Cls: Draw a1, c1: Draw a2, c2
End Sub

@Антихакер32 · 23.05.2014, 13:33

Компоненты на форме с помощью API ! ✰

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

Visual Basic
1
2
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Форма:

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
Option Explicit
'
'Стандартные компоненты с помощью API
'
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Const BS_PUSHBUTTON = &H0&
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const LVS_REPORT = &H1
Private Const ES_MULTILINE = &H4&
Private Const ES_AUTOVSCROLL = &H40&
Private Const WS_DLGFRAME = &H400000
Private Const WS_BORDER = &H800000
Private m_hButton As Long
Private m_hWndLV As Long
Private m_hEdit As Long
Private m_hLabel As Long
 
Private Sub Form_Load()
    Dim lngStyle As Long
    'Define style
    lngStyle = BS_PUSHBUTTON Or WS_CHILD Or WS_VISIBLE
    'Create the button
    m_hButton = CreateWindowEx(0&, "BUTTON", "Click Me!", lngStyle, 190, 10, 150, 50, Me.hWnd, 0&, _
    App.hInstance, ByVal 0&)
    'Define style
    lngStyle = WS_CHILD Or WS_VISIBLE Or LVS_REPORT
    'Create the listview
    m_hWndLV = CreateWindowEx(WS_EX_CLIENTEDGE, "SysListView32", vbNullString, lngStyle, 10, _
    10, 100, 100, Me.hWnd, 0, App.hInstance, ByVal 0&)
    'Define style
    lngStyle = WS_DLGFRAME Or ES_AUTOVSCROLL Or ES_MULTILINE Or WS_CHILD Or WS_VISIBLE
    'Create the textbox
    m_hEdit = CreateWindowEx(WS_EX_CLIENTEDGE, "EDIT", "TextBox", lngStyle, 10, 120, 240, 100, _
    Me.hWnd, 0&, App.hInstance, ByVal 0&)
    'Define style
    lngStyle = WS_BORDER Or WS_CHILD Or WS_VISIBLE
    'Create the label
    m_hLabel = CreateWindowEx(0&, "STATIC", "Label!", lngStyle, 260, 170, 150, 30, Me.hWnd, 0&, App.hInstance, _
    ByVal 0&)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'Cleanup
    Call DestroyWindow(m_hButton)
    Call DestroyWindow(m_hWndLV)
    Call DestroyWindow(m_hEdit)
    Call DestroyWindow(m_hLabel)
End Sub

@Антихакер32 · 23.05.2014, 22:03

Сохранение настроек Класс INI
Работа с консолью из своего окна ✰

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

класс:

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

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
Option Explicit
'
'    '© FelixMacintosh (CiberForum.ru)
'    'Интерактивная консоль
'
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, lpBuffer As Any, ByVal nBufferSize As Long, lpBytesRead As Long, lpTotalBytesAvail As Long, lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, 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 CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
'
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const DUPLICATE_SAME_ACCESS As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
Private Const SW_HIDE As Long = 0&
Private Const SW_SHOWNORMAL As Long = 1
Private Const SYNCHRONIZE = &H100000
'
Public Enum TimeOutConst
    WAIT_IGNORE = 0
    WAIT_LONG = 60000
    WAIT_INFINITE = (-1&)
    WAIT_TIMEOUT = 258
End Enum
'
Private Const TimeSleep = 20 'Моя константа времени паузы ожидания
'
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    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 Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
'Мои переменные:
Dim tSecurityAttributes As SECURITY_ATTRIBUTES
Dim tStartInfo As STARTUPINFO
Dim tProcessInfo As PROCESS_INFORMATION
'
Dim hInput As Long
Dim hOutput As Long
Dim hCmd As Long
Dim m_FullText As String
'
Dim BytesWritten As Long
Dim bBuffer() As Byte
Dim lLen As Long
Dim bRes As Boolean
Dim lLenBuff As Long
Dim lngExitCode&, lngResult&
'
Public Event ChangeText(ByVal Result As String, ByVal FullText As String, ByVal LenFullText As Long)
Public Event EndProcess()
 
Public Function Wait(NumShell&, Mileseconds As TimeOutConst)
    'Ждет завершения процесса
    'Возвращает хендл завершенного или не завершенного процесса
    'Арг: NumShell число возвращаемое функцией Shell
    '
    Dim hProc& 'Синхронизация процесса
    hProc = OpenProcess(SYNCHRONIZE, False, NumShell)
    Wait = WaitForSingleObject(hProc, Mileseconds)
    CloseHandle hProc
End Function
 
 
Public Function LineOut(LineIn$, Optional bCrLf As Boolean) As String
    'Возвращает ответ операционной системы
    'на введенную команду
    '
    Dim f&, inst&, Result$
    CharToOem LineIn, LineIn 'Перевод в DOS
    If bCrLf Then LineIn = LineIn & vbCrLf
    lngResult = WriteFile(hInput, ByVal LineIn, Len(LineIn), BytesWritten, 0&)
    If lngResult < 1 Then GoTo Error1
    Do 'Ждать процесс записи
        lngResult = WaitForSingleObject(hCmd, TimeSleep)
    Loop While (lngResult <> WAIT_TIMEOUT)
    'Запись произведена, теперь нужно получить ответ...
    '
    If PeekNamedPipe(hOutput, 0&, 0&, 0&, lLen, 0&) = 0 Then GoTo Error1
    If lLen = 0 Then
        'Возникла ошибка, возможно консоль ждет ответа
        '
        LineOut = LineOut & LineOut("rem Error", True) & LineOut(Chr(0), True)     '...Продолжить ввод ?
        Exit Function
    End If
    
    ReDim bBuffer(lLen)
    If ReadFile(hOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&) Then Else Exit Function
    Do 'Ждать процесс чтения
        lngResult = WaitForSingleObject(hCmd, TimeSleep)
        If lngResult < 1 Then GoTo Error1
    Loop While (lngResult <> WAIT_TIMEOUT)
    
    
    LineOut = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
    OemToChar LineOut, LineOut 'Перевод в Windows
    m_FullText = m_FullText & LineOut
    Result = Mid$(LineOut, Len(LineIn) + 1)
 
    'Текст изменился значит вызвать это событие
    If Len(Result) Then If Asc(Result) = 12 Then _
    m_FullText = Mid$(LineOut, Len(LineIn) + 2) '''Команда =CLS=
    RaiseEvent ChangeText(Result, m_FullText, Len(m_FullText))
 
    Exit Function
Error1:
    'Завершение процесса
    m_FullText = m_FullText & LineIn
    RaiseEvent ChangeText(Result, m_FullText, Len(m_FullText))
    Call Class_Terminate
End Function
 
Private Sub Class_Initialize()
    Dim lCurrentID As Long
    lCurrentID = GetCurrentProcess()
 
    With tSecurityAttributes
        .nLength = Len(tSecurityAttributes)
        .bInheritHandle = 1
    End With
 
    With tStartInfo
        .cb = Len(tStartInfo)
        .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
        .wShowWindow = SW_HIDE '  SW_SHOWNORMAL
        If CreatePipe(hOutput, .hStdOutput, tSecurityAttributes, 0) = 0 Then GoTo Error1
        If CreatePipe(.hStdInput, hInput, tSecurityAttributes, 0) = 0 Then GoTo Error1
        If DuplicateHandle(lCurrentID, .hStdOutput, lCurrentID, .hStdError, _
        0&, True, DUPLICATE_SAME_ACCESS) = 0 Then GoTo Error1
    End With
 
    
    If CreateProcess(vbNullString, "cmd", tSecurityAttributes, tSecurityAttributes, 1, NORMAL_PRIORITY_CLASS, _
    ByVal 0&, vbNullString, tStartInfo, tProcessInfo) = 0 Then GoTo Error1
 
    With tProcessInfo
        Call CloseHandle(.hThread):   hCmd = .hProcess
        If .dwProcessId > 0 And .hProcess > 0 Then
            Do Until CBool(PeekNamedPipe(hOutput, 0&, 0&, 0&, lLen, 0&)) And lLen
                DoEvents 'Ожидание возникновения нового процесса
                Sleep TimeSleep
            Loop
            ReDim bBuffer(lLen)
            Call ReadFile(hOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&)
            m_FullText = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
            OemToChar m_FullText, m_FullText 'Перевод в Windows
            RaiseEvent ChangeText("", m_FullText, Len(m_FullText))
        Else
            GoTo Error1
        End If
    End With
 
    Exit Sub
Error1:
    Call Class_Terminate
End Sub
 
Private Sub Class_Terminate()
    lngResult = TerminateProcess(tProcessInfo.hProcess, lngExitCode)
    Debug.Assert Not (lngExitCode > 0) 'Процесс не смог завершиться...
    lngResult = WaitForSingleObject(tProcessInfo.hProcess, WAIT_LONG)
    lngResult = CloseHandle(tProcessInfo.hThread)
    lngResult = CloseHandle(tProcessInfo.hProcess)
    lngResult = CloseHandle(hInput)
    lngResult = CloseHandle(hOutput)
    RaiseEvent EndProcess
End Sub
 
Public Property Get FullText() As String
    FullText = m_FullText
End Property
 
Public Sub Restart()
    m_FullText = ""
    Class_Terminate
    Class_Initialize
End Sub

форма:

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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
Option Explicit
'
'Отладка DllRegLib
'
Dim o
Dim rl As DllRegLib.RegLib
Dim WithEvents Console As DllRegLib.Console
Dim WithEvents cmmCls As CommandButton
Dim WithEvents cmmRestart As CommandButton
Dim WithEvents lb As Label
 
Private Sub cmmCls_Click()
    Text1.SetFocus
    SendKeys "cls" & "{Enter}", True
End Sub
 
Private Sub cmmRestart_Click()
    Text1.SetFocus
    Console.restart
End Sub
 
Private Sub Console_ChangeText(ByVal Result As String, ByVal FullText As String, ByVal LenFullText As Long)
    Text1 = Console.FullText
    Text1.SelStart = LenFullText
End Sub
 
Private Sub Form_Load()
    '----------- Добавить кнопки
    Set cmmCls = Controls.Add("vb.CommandButton", "cmmCls")
    cmmCls.Visible = True: cmmCls.Caption = "Очистить"
    Set cmmRestart = Controls.Add("vb.CommandButton", "cmmRestart")
    cmmRestart = cmmCls
    cmmRestart.Visible = True: cmmRestart.Caption = "Перезапустить"
    For Each o In Controls: o.FontBold = 1: Next
    Set lb = Controls.Add("vb.Label", "lb"): lb.AutoSize = 1: lb.FontSize = 15
    Set Console = New DllRegLib.Console
    Me.Caption = Split(Console.FullText, vbCrLf, 2)(0)
    '''
    Me.Move 0, 0, 11000, 4000
    With Screen: Me.Move (.Width - Me.Width) / 2, (.Height - Me.Height) / 3: End With
    With Text1: .ForeColor = .BackColor:  .BackColor = 0: End With
    
    Text1 = Console.FullText
    Text1.SelStart = Len(Console.FullText)
End Sub
 
Private Sub Form_Activate()
    Dim dwStyle&
    Dim RegLib As New DllRegLib.RegLib
    Set Console = New DllRegLib.Console 'или CreateObject("DllRegLib.Console")
End Sub
 
Private Sub Form_Resize()
    On Error Resume Next
    lb.Caption = cmmCls.Caption
    cmmCls.Move 0, Text1.Height, lb.Width, lb.Height
     lb.Caption = cmmRestart.Caption
    cmmRestart.Move cmmCls.Width, Text1.Height, lb.Width, lb.Height
    Text1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight - cmmCls.Height
End Sub
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    If Text1.SelStart < (Len(Console.FullText)) + Abs(KeyAscii = 8) Then KeyAscii = 0
End Sub
 
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim s$
    If KeyCode = 13 Then
        Call Console.LineOut(Mid$(Text1, Len(Console.FullText) + 1))
        Text1 = Console.FullText
    End If
End Sub

Хотелось бы добавить что требуется соблюдать осторожность
и не вводить что попало, это не блокнот !

для проверки, в открывающемся окне можно написать это..

Code
1
start "" https://www.cyberforum.ru/post6215077.html

...запустится это-же окно
или запустить простую команду dir

@Антихакер32 · 26.05.2014, 12:57

DllErr

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

Как использовать !?
просто перенесите эту dll в свою папку, где будет находиться Ваш проект

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
Option Explicit
 
Private Declare Function cErr Lib "dllERR.dll" Alias "cErr_A" () As Object
'Function Add(Number&, Description$) As Long
'    'Создаёт номер и дискриптор ошибки
'    'Возвращает успешно добавленный номер
'Sub Raise(Expression As Boolean, ByVal Index$, Optional Source$)
'    'Вызов ошибки по указанному индексу
'    'Арг: выражение // номер или ключ // источник
'Function Remove(ByVal Index$) As Boolean
'    'Удаляет указанный индекс ошибки
'    'Возвращает успех
Dim mErr As Object
 
Private Sub Form_Click()
    mErr.Raise 1, 101, "Form_Click"
End Sub
 
Private Sub Form_Load()
    Set mErr = cErr
    With mErr
        'Добавляем данные об ошибке ...
        .Add 101, "Проверочная ошибка"
    End With
End Sub

@Антихакер32 · 28.05.2014, 06:00

ActiveX EXE

Что такое ActiveX EXE ?
Зачем нужна ActiveX EXE, и с чем её едят читайте здесь

перемещаемая папка:

вызов приложения из архива

@The trick · 30.05.2014, 11:11

Использование COM/ActiveX библиотек без регистрации в реестре.

Привет всем. Выкладываю модуль для работы с COM-Dll без регистрации в реестре.
Модуль имеет несколько функций:

GetAllCoclasses - возвращает список имен классов вместе с идентификаторами извлеченными из библиотеки типов.
CreateIDispatch - создает реализацию IDispatch на основе объекта и имени интерфейса.
CreateObjectEx2 - создает объект по имени.
CreateObjectEx - создает объект по CLSID.
UnloadLibrary - Выгружает библиотеку, если та не используется.

Ссылка.

@The trick · 31.05.2014, 03:00

Модуль для перехвата функций на VB6

Разработал простой модуль с помощью которого можно перехватывать STDCALL функции и методы COM объектов. Перехват реализован с помощью сплайсинга, никаких синхронизаций нет, так что в многопоточной программе могут возникнуть проблемы. Пользоваться нужно осторожно, т.к. любая ошибка фатальна, нельзя вызывать перехваченную функцию, если не снят перехват, т.к. произойдет переполнение стека. Перехват может понадобится во многих случаях, в примере я использую перехват для создания многострочного текстбокса в рантайме.

Ссылка.

@The trick · 31.05.2014, 18:35

Использование ActiveX контролов без регистрации в реестре.

Разработал модуль с помощью которого можно работать с ActiveX контролами незарегистрированными в реестре, а также реализована поддержка событий. В нем содержится функция ControlsAdd (аналогия метода формы Controls.Add), с помощью которой можно добавлять контролы используя путь к библиотеке и CLSID контрола. Модуль особо не тестировался, поэтому что-то может не заработать, но ActiveX контролы, созданные в VB, а также несколько стандартных библиотек работали нормально. В качестве примера, я создал 2 тестовые библиотеки и главную программу, в которой используются контролы из этих библиотек.

В качестве ProgID, нужно указывать любую строку вида xxxx.xxxx (xxx - произвольное число символов). После этого можно уже добавлять используя этот ProgID через стандартный метод

Visual Basic
1
Controls.Add (ProgID, Name)

MiscStatus - параметр, отвечающий за создание и отображение объекта (обычно 131473).
Также можно сделать (я не делал) перебор всех коклассов в библиотеке, получение их имен, идентификаторов класса, и уже использовать в качестве ProgID строку вида LibraryName.TypeName, тогда функцию можно упростить и сделать ее почти такой-же как и одноименный метод формы.

Работа функции основана на перехвате необходимых функций и создание условий при которых VB "думает" что библиотека зарегистрирована. Для перехвата я использовал свой модуль modTrickHook.bas.
Перехватывая CLSIDFromProgID, возвращаем CLSID нужного нам элемента управления, тем самым VB6 добавляет в коллекцию лицензий наш незарегистрированный класс. Перехватывая CoGetClassObject, получаем объект фабрики классов для создания экземпляров, вручную вызывая функцию DllGetClassObject из библиотеки. Перехват OleRegGetMiscStatus дает нам возможность задать MiscStatus для незарегистрированного элемента, а RegQueryValue получаем пути к библиотеке, библиотеке типов и версию (я использовал 1.00). Далее подменяя LoadRegTypeLibHook на LoadTypeLibEx грузим библиотеку типов не регистрируя ее в реестре (теперь мы можем использовать события). В дополнение идет перехват DllFunctionCall для динамической смены имени библиотеки и вызова DllGetClassObject, а также обнуление адреса функции и hInstance библиотеки, т.к. иначе функция будет вызываться по тому же адресу, а DllFunctionCall больше не вызовется.

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

Ссылка.

@Антихакер32 · 07.06.2014, 07:53

Крестики нолики

С музыкой

Код игры

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
Option Explicit: Option Base 0
'
'© Антихакер32™    Игра крестики нолики
'
Private Const Fora = 2 'Фора для нолика не должна быть => X :)
Private Const X = 3, Y = 3
Private Const mx = 800, my = 500
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Dim WithEvents cm1 As CommandButton, c(X * Y - 1) As CommandButton
Dim WithEvents cm2 As CommandButton
Dim WithEvents tmr As Timer
Dim WithEvents frr As Frame
Dim x1&, y1&, i&, f&
 
Private Sub Pobeda(Optional ID$, Optional Idx&)
    Dim b As Boolean
    Static sX&, s0&
    b = Len(ID)
    If b Then If ID = "X" Then sX = sX + 1 Else s0 = s0 + 1
    ID = IIf(b, "Победил " & ID, "Ничья")
    cm2.Caption = ID & ", Переиграть ?"
    cm2.Enabled = True
    If b = False Then Exit Sub
    frr.Caption = "Счёт: Крестик(" & sX & ") / Нолик(" & s0 & ")"
    sndPlaySound "RTM_SystemExit.wav", &H1
    Select Case Idx
    Case X * Y
        y1 = 0
        For x1 = 0 To X - 1
            c(X * y1 + x1).FontBold = 1
            y1 = y1 + 1
        Next
    Case X * Y + 1
        y1 = 0
        For x1 = X - 1 To 0 Step -1
            c(X * y1 + x1).FontBold = 1
            y1 = y1 + 1
        Next
    Case X To X + Y
        For y1 = 0 To Y - 1
            c(y1 * X + Idx - X).FontBold = 1
        Next
    Case 0 To Y - 1
        For x1 = 0 To X - 1
            c(Idx * X + x1).FontBold = 1
        Next
    End Select
End Sub
 
Private Sub Proverka()
    Dim n&, j$(), f&
    j = Split("X 0")
    For f = 0 To 1
        For y1 = 0 To Y - 1: n = 0: For x1 = 0 To X - 1
                GoSub 1: If n = X Then Pobeda j(f), y1: Exit Sub
        Next: Next
        For x1 = 0 To X - 1: n = 0: For y1 = 0 To Y - 1
                GoSub 1: If n = Y Then Pobeda j(f), Y + x1: Exit Sub
        Next: Next
        y1 = 0: n = 0
        For x1 = 0 To X - 1
            GoSub 1: If n = X Then Pobeda j(f), X * Y: Exit Sub
            y1 = y1 + 1
        Next
        y1 = 0: n = 0
        For x1 = X - 1 To 0 Step -1
            GoSub 1: If n = X Then Pobeda j(f), X * Y + 1: Exit Sub
            y1 = y1 + 1
        Next
    Next
    Exit Sub
1
    On Error Resume Next
    If c(X * y1 + x1).Caption = j(f) Then n = n + 1
    Return
End Sub
 
Private Sub cm2_Click()
    For y1 = 0 To Y - 1: For x1 = 0 To X - 1
            c(X * y1 + x1).Caption = ""
    Next: Next
    cm2.Enabled = False
    For f = 1 To Fora: Nolic: Next
    For f = 0 To X * Y - 1: c(f).FontBold = 0: Next
End Sub
 
Private Sub Nolic()
    If cm2.Enabled Then Exit Sub
    Dim coll As Collection
    Set coll = New Collection
    For y1 = 0 To Y - 1: For x1 = 0 To X - 1
            i = y1 * X + x1
            If c(i).Caption = "" Then coll.Add c(i), c(i).Name
    Next: Next
    Randomize Timer
    If coll.Count Then
        coll(Fix(Rnd * coll.Count) + 1).Caption = "0"
    Else
        Proverka
        Pobeda
    End If
End Sub
 
Private Sub cm1_Click()
    If cm1.Caption = "" And cm2.Enabled = False Then
        cm1.Caption = "X": Proverka: Nolic: Proverka
    End If
End Sub
 
 
Private Sub tmr_Timer()
    For y1 = 0 To Y - 1: For x1 = 0 To X - 1
            i = y1 * X + x1
            If c(i).hWnd = GetCapture Then Set cm1 = c(i)
    Next: Next
End Sub
 
Private Sub CrMartix()
    Const ram = 45, top = 180
    Me.Caption = "Игра *Крестики нолики* © Антихакер32™"
    Set frr = Me.Controls.Add("vb.Frame", "frr")
    For y1 = 0 To Y - 1: For x1 = 0 To X - 1
            i = X * y1 + x1
            Set c(i) = Me.Controls.Add("vb.CommandButton", "c_" & i, frr)
            c(i).Move x1 * mx + ram, y1 * my + top, mx, my
            c(i).Visible = True
    Next: Next
    Set cm2 = Me.Controls.Add("vb.CommandButton", "cm2", frr)
    cm2.Move ram, y1 * my + top, mx * X, my: y1 = y1 + 1
    cm2.Enabled = False: cm2.Visible = True
    frr.Move 100, 100, mx * X + ram * 2, my * y1 + ram * 2 + top
    frr.Caption = "Счёт: X/0"
    frr.Visible = True
    Set tmr = Me.Controls.Add("vb.Timer", "tmr")
    tmr.Interval = 50
    For f = 1 To Fora: Nolic: Next
End Sub
 
Private Sub Form_Load()
    CrMartix
End Sub

>> DownLoad <<

@Антихакер32 · 09.06.2014, 03:34

Интерактивный ✰ спойлер ✰

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

Процесс проектирования

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
Option Explicit
'
'   © Антихакер32™
'
'
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
'
Public Enum FlagsSpoilerStyle
    [По умолчанию] = 0
    [Кнопка слева] = 1
End Enum
'
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Sub 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)
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'
'Default Property Values:
Const m_def_Style = 0
Const def_Exp = 280 'Высота кнопки
Const HWND_TOPMOST = -1
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const GWL_EXSTYLE = (-20)
Const WS_EX_TOOLWINDOW = 128
'Property Variables:
Dim m_Style As FlagsSpoilerStyle
Dim WithEvents cm1 As CommandButton
Dim sh1 As Shape
Dim mSpoilerAction As Boolean
Dim oldParRect As RECT, mRect As RECT
Dim ResizeAction As Boolean
 
Public Sub WActivate()
    On Error GoTo errr
    If SpoilerAction Then SpoilerAction = False
errr:
End Sub
 
Public Sub WMove()
    Static Rect1 As RECT, Rect2 As RECT
    On Error GoTo errr
    If mSpoilerAction Then
        GetWindowRect Parent.hWnd, Rect1
        GetWindowRect hWnd, Rect2
        With Rect2
            .Left = .Left + (Rect1.Left - oldParRect.Left)
            .Top = .Top + (Rect1.Top - oldParRect.Top)
            SetWindowPos hWnd, -1, .Left, .Top, 0, 0, SWP_NOSIZE
        End With
        oldParRect = Rect1
    End If
errr:
End Sub
 
Private Property Get SpoilerAction() As Boolean
    SpoilerAction = mSpoilerAction
End Property
 
 
Private Property Let SpoilerAction(ByVal vNewValue As Boolean)
    Static Rect1 As RECT, Rect2 As RECT, Rect3 As RECT, Border&
    On Error GoTo errr
    GetWindowRect Parent.hWnd, Rect1
    GetWindowRect hWnd, Rect2
    ResizeAction = True
    If vNewValue Then
        With Rect2
            .Left = Rect1.Left + (.Left - Rect1.Left)
            .Top = Rect1.Top + (.Top - Rect1.Top)
            SetWindowPos hWnd, 0, .Left, .Top, 0, 0, SWP_NOSIZE
            SetParent hWnd, 0
            oldParRect = Rect1
        End With
        Select Case m_Style
        Case [По умолчанию]: Height = sh1.Height
        Case [Кнопка слева]: Width = sh1.Width
        End Select
    Else
        GetClientRect Parent.hWnd, Rect3
        With Rect2
            .Left = (.Left - (Rect1.Right - Rect3.Right))
            .Left = .Left + (mRect.Left - .Left)
            .Top = (.Top - (Rect1.Bottom - Rect3.Bottom))
            .Top = .Top + (mRect.Top - .Top)
            SetParent hWnd, Parent.hWnd
            SetWindowPos hWnd, 0, .Left, .Top, 0, 0, SWP_NOSIZE
        End With
        Select Case m_Style
        Case [По умолчанию]: Height = def_Exp
        Case [Кнопка слева]: Width = def_Exp
        End Select
    End If
    mSpoilerAction = vNewValue
errr:
    ResizeAction = False
End Property
 
Private Sub cm1_Click()
    SpoilerAction = Not SpoilerAction
End Sub
 
Private Sub UserControl_Initialize()
    Set cm1 = Controls.Add("vb.CommandButton", "cm1_" & hWnd)
    Set sh1 = Controls.Add("vb.Shape", "sh1_" & hWnd)
    sh1.Visible = 1: cm1.Visible = 1
    SetWindowLong hWnd, GWL_EXSTYLE, _
    GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_TOOLWINDOW
End Sub
 
Private Sub UserControl_Resize()
    On Error Resume Next
    If ResizeAction Then Exit Sub
    With mRect
        If Not mSpoilerAction Then
            sh1.Move 0, 0, Width, Height
            .Left = Extender.Left \ Screen.TwipsPerPixelX
            .Top = Extender.Top \ Screen.TwipsPerPixelY
        End If
        Select Case m_Style
        Case [По умолчанию]: cm1.Move 0, 0, sh1.Width, def_Exp
        Case [Кнопка слева]: cm1.Move 0, 0, def_Exp, sh1.Height
        End Select
    End With
End Sub
 
Private Sub UserControl_Show()
    Dim o As Object
    If Ambient.UserMode Then
        SpoilerAction = 1
        Hook Extender
    End If
End Sub
 
Private Sub UserControl_Terminate()
     UnHook
End Sub
 
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get Style() As FlagsSpoilerStyle
    Style = m_Style
End Property
 
Public Property Let Style(ByVal New_Style As FlagsSpoilerStyle)
    m_Style = New_Style
    PropertyChanged "Style"
    UserControl_Resize
End Property
 
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_Style = m_def_Style
End Sub
 
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
    UserControl_Resize
End Sub
 
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
 
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
End Sub

Исходник:
>> DownLoad <<

@Антихакер32 · 13.06.2014, 00:31

Полупрозрачный *Диспетчер задач*.. ✰

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

Форма в архиве:
>>✰ DownLoad ✰<<

@Антихакер32 · 14.06.2014, 18:29

Модуль многократного использования хуков

Модуль:

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

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
Option Explicit
'
'        © Антихакер32™
'        Модуль многократного использования хуков,
'        и отлова любого оконного сообщения
'
Public Const GWL_WNDPROC = -4
Public Const WM_CLOSE = &H10
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'------------------------------------------------------------------------------------------------------
Dim mDic As Object
Const Item = "Item_"
 
Function CloseHook(hWnd&)
    '
    'Закрывает все хуки связанные с этим окном
    'После этого можно останавливать программу
    '
    Dim dic As Object
    On Error GoTo errr
    If mDic Is Nothing Then Exit Function
    CloseHook = SetWindowLong(hWnd, GWL_WNDPROC, 0)
    If CloseHook Then
        mDic.Remove (hWnd)  'Удаление его из списка
    End If
errr:
End Function
 
Function AddChildHook(Child As Object, ParentProcName$, ByVal Message&)
    '
    'Добавление хука для отлова сообщений от дочернего контрола
    'Арг: Дочерний объект// вызываемое имя отцовой процедуры // сообщения окна
    '
    Dim dic As Object, swl&
    On Error GoTo errr
    If mDic Is Nothing Then Set mDic = CreateObject("Scripting.Dictionary")
    AddChildHook = Child.hWnd
    If mDic.Exists(AddChildHook) Then
        Set dic = mDic(AddChildHook)
        dic.Add Item & dic.Count, Array(Child.Parent, ParentProcName, Message)
    Else
        Set dic = CreateObject("Scripting.Dictionary")
        swl = SetWindowLong(AddChildHook, GWL_WNDPROC, AddressOf WindowProc)
        If swl Then
            dic.Add "SWL", swl
            dic.Add Item & dic.Count, Array(Child.Parent, ParentProcName, Message)
            mDic.Add AddChildHook, dic
        End If
    End If
errr:
End Function
 
Function AddParentHook(Child As Object, ChildProcName$, ByVal Message&)
    '
    'Добавление хука для отлова сообщений от родительского окна
    'Арг: Дочерний объект// вызываемое имя дочерней процедуры // сообщения окна
    '
    Dim dic As Object, swl&
    On Error GoTo errr
    If mDic Is Nothing Then Set mDic = CreateObject("Scripting.Dictionary")
    AddParentHook = Child.Parent.hWnd
    If mDic.Exists(AddParentHook) Then
        Set dic = mDic(AddParentHook)
        dic.Add Item & dic.Count, Array(Child, ChildProcName, Message)
    Else
        Set dic = CreateObject("Scripting.Dictionary")
        swl = SetWindowLong(AddParentHook, GWL_WNDPROC, AddressOf WindowProc)
        If swl Then
            dic.Add "SWL", swl
            dic.Add Item & dic.Count, Array(Child, ChildProcName, Message)
            mDic.Add AddParentHook, dic
        End If
    End If
errr:
End Function
 
Function AddHook(Obj As Object, ProcName$, ByVal Message&)
    '
    'Добавление хука для отлова сообщений от указанного окна
    'Арг: Объект// вызываемое имя процедуры // сообщения окна
    '
    Dim dic As Object, swl&
    On Error GoTo errr
    If mDic Is Nothing Then Set mDic = CreateObject("Scripting.Dictionary")
    AddHook = Obj.hWnd
    If mDic.Exists(AddHook) Then
        Set dic = mDic(AddHook)
        dic.Add Item & dic.Count, Array(Obj, ProcName, Message)
    Else
        Set dic = CreateObject("Scripting.Dictionary")
        swl = SetWindowLong(AddHook, GWL_WNDPROC, AddressOf WindowProc)
        If swl Then
            dic.Add "SWL", swl
            dic.Add Item & dic.Count, Array(Obj, ProcName, Message)
            mDic.Add AddHook, dic
        End If
    End If
errr:
End Function
 
Private Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam _
As Long) As Long
    '
    'Перечисление всех ранее добавленных хуков
    '
    Dim dic As Object, i&, a
    '
    On Error GoTo errr
    If mDic.Exists(hWnd) Then
        Set dic = mDic(hWnd): i = 1
        While dic.Exists(Item & i)
            a = dic(Item & i):   i = i + 1
            If Msg = a(2) Then
                WindowProc = CallByName(a(0), a(1), VbMethod, mDic(hWnd)("SWL"), hWnd, Msg, wParam, lParam)
                If WindowProc = 0 Then Exit Function
            End If
        Wend
errr:
        On Error Resume Next
        WindowProc = CallWindowProc(mDic(hWnd)("SWL"), hWnd, Msg, wParam, lParam)
    End If
 
End Function

Форма:

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

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
Option Explicit
'
'Пустая форма
'Пример использования модуля SubClass
'
Const HTCAPTION = 2
Const WM_MOVE = &H3
Const WM_SIZE = &H5
Const WM_LBUTTONDOWN = &H201
Const WM_NCLBUTTONDOWN = &HA1
Dim WithEvents tx1 As TextBox
Dim WithEvents cm1 As CommandButton
Dim WithEvents cm2 As CommandButton
 
Dim h&, h1&
 
Private Sub cm2_Click()
    h1 = AddChildHook(tx1, "TXMove", WM_LBUTTONDOWN)
End Sub
 
Private Sub cm1_Click()
    CloseHook h1
End Sub
 
Private Sub Form_Load()
    Dim c(1) As CommandButton, f&
    Set tx1 = Controls.Add("vb.TextBox", "tx1")
    tx1.Move 100, 100, 1500, 500: tx1.Text = "Сдвинь меня !": tx1.Visible = 1
    Set c(0) = Controls.Add("vb.CommandButton", "cm1")
    Set c(1) = Controls.Add("vb.CommandButton", "cm2")
    For f = 0 To 1: c(f).Move 100, 100 + (500 * f), 1500, 500
        c(f).Visible = 1: c(f).Caption = Choose(f + 1, "Закрыть хук", "Активировать хук")
    Next
    Set cm1 = c(0): Set cm2 = c(1)
    h1 = AddHook(Me, "WMove", WM_MOVE)
End Sub
 
Public Function WMove(ParamArray arg())
    Debug.Print Me.Left, Me.Top
End Function
 
Public Function TXMove(ParamArray arg())
    arg(2) = WM_NCLBUTTONDOWN
    arg(3) = HTCAPTION
    TXMove = 1
End Function
 
Private Sub Form_Unload(Cancel As Integer)
    CloseHook h
    CloseHook h1
End Sub

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

@Pro_grammer · 14.06.2014, 19:11

Win32 API Text File Viewer (Win32API.txt file viewer) 1.1.5d

Сразу оговорюсь, что не моё, но просто грех было не поделится с народом. Огромный сборник всевозможных деклараций WinAPI ( папка Mr 305 API Data) с удобным просмотром, написано всё на VB6 + исходники. Структуры, константы, декларации - всё можно сразу вставить в свой проект или буфер обмена.
Рекомендую для использования в повседневной деятельности для программирования под Винду.

Готовые решения и полезные коды на Visual Basic 6.0

@Антихакер32 · 15.06.2014, 08:58

Супер код

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

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

могу продемонстрировать только часть кода...

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

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
Option Explicit
'
'   © Антихакер32™ Нативная DLL создаваемая по необходимости
'   И пример использования модуля SubClass
'   P.S Ничего устанавливать не нужно, требуется пустая форма
'
Const HTCAPTION = 2
Const WM_MOVE = &H3
Const WM_SIZE = &H5
Const WM_LBUTTONDOWN = &H201
Const WM_NCLBUTTONDOWN = &HA1
Dim WithEvents tx1 As TextBox
Dim WithEvents cm1 As CommandButton
Dim WithEvents cm2 As CommandButton
 
Private Declare Function Hooks Lib "MHook.dll" () As Object
'Экспортируемые функции
'Function AddChildHook(Child As Object, ByVal ParentProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от дочернего контрола
'    'Арг: Дочерний объект// вызываемое имя отцовой процедуры // сообщения окна
'    '
'Function AddParentHook(Child As Object, ByVal ChildProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от родительского окна
'    'Арг: Дочерний объект// вызываемое имя дочерней процедуры // сообщения окна
'    '
'Function AddHook(Obj As Object, ByVal ProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от указанного окна
'    'Арг: Объект// вызываемое имя процедуры // сообщения окна
'    '
'Function CloseHook(ByVal hwnd&) As Long
'    'Закрывает все хуки связанные с этим окном
'    'После этого можно останавливать программу
'    '
'Function CloseAllHooks() As Long
'    'Закрывает все ранее открытые хуки, и возвращает их число
    '
 
Dim h&, h1&
Dim mHooks As Object
 
Private Sub cm2_Click()
    h1 = mHooks.AddChildHook(tx1, "TXMove", WM_LBUTTONDOWN)
End Sub
 
Private Sub cm1_Click()
    mHooks.CloseHook h1
End Sub
 
Private Sub Form_Load()
    Dim c(1) As CommandButton, f&
    AvtoCod
    Set mHooks = Hooks 'Загружаем класс
    
    Set tx1 = Controls.Add("vb.TextBox", "tx1")
    tx1.Move 100, 100, 1500, 500: tx1.Text = "Сдвинь меня !": tx1.Visible = 1
    Set c(0) = Controls.Add("vb.CommandButton", "cm1")
    Set c(1) = Controls.Add("vb.CommandButton", "cm2")
    For f = 0 To 1: c(f).Move 100, 100 + (500 * f), 1500, 500
        c(f).Visible = 1: c(f).Caption = Choose(f + 1, "Закрыть хук", "Активировать хук")
    Next
    Set cm1 = c(0): Set cm2 = c(1)
    h1 = mHooks.AddHook(Me, "WMove", WM_MOVE)
End Sub
 
Public Function WMove(ParamArray Arg())
    Debug.Print Me.Left, Me.Top
End Function
 
Public Function TXMove(ParamArray Arg())
    Arg(2) = WM_NCLBUTTONDOWN
    Arg(3) = HTCAPTION
    TXMove = 1
End Function
 
Sub AvtoCod()
    'Автоматически созданный код внешней программой
    Dim j$(18), s$, f&, u&, i&, b() As Byte
    
    ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''
     ''''  ''''  ''''  ''''  Объем 16-ричных данных   ''''  ''''  ''''  ''''
     
     ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''  ''''
     
    s = Join(j, ""): u = Len(s) \ 2 - 1: i = -1: ReDim Preserve b(u)
    For f = 0 To u: i = i + 2: b(f) = CByte("&h" & Trim(Mid$(s, i, 2))): Next
    ChDir App.Path: s = "MHook.zip": f = FreeFile: Open s For Binary As #f: Put #f, 1, b: Close #f
    Dim ShellApp As Object, Parse As Object, s1 As String, v As Variant
    Set ShellApp = CreateObject("Shell.Application"): On Error Resume Next
    For Each v In Array("MHook.dll")
        If CreateObject("Scripting.FileSystemObject").FileExists(CStr(v)) Then GoTo FileExists
        Set Parse = ShellApp.NameSpace((App.Path & "\" & s)).ParseName((v))
        ShellApp.NameSpace((App.Path)).CopyHere Parse
        Do: DoEvents
            s1 = b: f = FreeFile: Open CStr(v) For Binary As #f: ReDim Preserve b(LOF(f) - 1): Get #f, 1, b: Close #f
        Loop While s1 <> CStr(b) 'Повторять пока есть разница данных
FileExists:
    Next
    Kill s
End Sub

@The trick · 16.06.2014, 01:05

Класс для сабклассинга окон и классов.

Разработал класс с помощью которого можно работать с сабклассингом. Класс имеет событие WndProc, которое вызывается при получении окном сообщения. Также имеется возможность поставить сабклассинг на класс окон. Имеются методы для приостановки сабклассинга и снятия его, а также получения информации о сабклассинге. Работать очень удобно, т.к. можно останавливать проект кнопкой стоп без последствий. Запускать лучше через Start with full compile, т.к. это предотвратит вылеты, при неудачной компиляции. Я себе вообще вывел отдельно кнопку рядом с обычной компиляцией, и пользуюсь ей.

Название: Безымянный2.png
Просмотров: 1712

Размер: 1.9 Кб

Немного о работе с классом. Для установки сабклассинга на окно, вызывается метод Hook, с хендлом окна. Если метод возвращает True, значит сабклассинг установлен. Обрабатывая событие WndProc, можно изменять поведение окна. В аргумент Ret можно передавать возвращаемое значение, если нужно вызвать процедуру по умолчанию, то нужно передать в аргументе DefCall True.
Для установки сабклассинга на группу окон (класс), нужно вызвать метод HookClass, передавая хендл окна чей класс нужно засабклассировать. При удачном выполнении метод вернет True. Сабклассинг будет действовать начиная со следующего созданного окна этого класса, т.е. на переданный параметр сабклассинг действовать не будет. Также по умолчанию этот вид сабклассинга приостановлен. Я сделал это из-за того, что если не обработать сообщения создания окон должным образом, то проект не запустится с ошибкой Out of memory.
Для снятия сабклассинга нужно вызвать метод Unhook, возвращающий True при удачном выполнении.
Для приостановки и возобновления сабклассинга предусмотрены методы PauseSubclass и ResumeSubclass, возвращающие True при удачном выполнении.
Свойство hWnd возвращает хендл окна, на который установлен сабклассинг (для случая установки сабклассинга на класс окон, возвращает переданный параметр).
Свойство IsSubclassed предназначено для определения, установлен ли сабклассинг или нет.
Свойство IsClass возвращает True, если сабклассинг устанавливался на класс окон.
Свойство IsPaused возвращает True, если сабклассинг приостановлен.

Для теста я сделал небольшой проект, в котором используются возможности сабклассинга. Установка таймера (SetTimer), замена стандартного контекстного меню текстбокса, ограничение на изменение размеров формы, отлов "прихода"/"ухода" мыши на/из котрол(а).

Ссылка.

@Антихакер32 · 18.06.2014, 01:30

The Trick
Спасибо, за выполненную работу
идея с классом, очень понравилась

Сообщение от The trick

Запускать лучше через Start with full compile, т.к. это предотвратит вылеты, при неудачной компиляции. Я себе вообще вывел отдельно кнопку рядом с обычной компиляцией, и пользуюсь ей.

кстати у меня кнопки компиляции тоже имеются, но выглядят они со смыслом

Настройки среды VB6

Добавлено через 4 часа 43 минуты
Универсальное решение !✰

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

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
Function CheckFiles(ByVal ZipUrl$, ByVal Folder$, ParamArray ParseNames()) As Long
    'Проверяет наличие файлов, указанных в аргументах ParseNames
    'И при необходимости докачивает их в указанную папку Folder
    'Если папка не указанна, то отсутствующие файлы будут скопированны в текущую папку
    '© Антихакер32™  ...2014
    '
    Const Promt0 = "Отсутствуют необходимые компоненты" & vbCrLf
    Const Promt1 = Promt0 & "Отсутствует соединение с интернетом, для того чтоб их скачать"
    Const Promt2 = Promt0 & "Указанный URL не является ZIP-папкой с компонентами"
    Const Promt3 = Promt0 & "URL не указан, либо указан неправильно"
    Dim vEach, OldDir$, ArcName$, f&, zExists As Boolean, s$, b() As Byte
    Dim ShellApp As Object, Fso As Object, Zip As Object
    Set Fso = CreateObject("Scripting.FileSystemObject"): OldDir = CurDir$
    If Fso.FolderExists(Folder) Then ChDir Folder Else Folder = OldDir
    For Each vEach In ParseNames
        If Fso.FileExists(vEach) Or Fso.FolderExists(vEach) Then
            GoTo NextEach
        ElseIf Len(ZipUrl) Then On Error Resume Next
            If Not zExists Then 'Обращение к интернету и закачка необходимых файлов
                If InternetGetConnectedState(0&, 0&) = 0 Then MsgBox Promt1, vbInformation: End
                f = 32: ArcName = Space$(f): Randomize Timer 'Случайное имя архива
                For f = 1 To f: Mid(ArcName, f, 1) = Chr(Asc("a") + Rnd * (Asc("z") - Asc("a")))
                Next: ArcName = ArcName & ".zip"
                If URLDownloadToFile(0, ZipUrl, ArcName, 0, 0) = 0 Then zExists = True Else GoTo incorrectaddress
                Set ShellApp = CreateObject("Shell.Application")
                Set Zip = ShellApp.NameSpace(Fso.GetAbsolutePathName(ArcName))
                If Zip Is Nothing Then MsgBox Promt2, vbInformation: Kill ArcName: End
            End If: 'On Error GoTo 0
            ShellApp.NameSpace((Folder)).CopyHere Zip.ParseName((vEach))
            f = FreeFile: Open CStr(vEach) For Binary As #f: ReDim Preserve b(LOF(f) - 1)
            Do: DoEvents: s = b: Get #f, 1, b: Loop While s <> CStr(b) 'Повторять пока есть разница данных
            Close #f 'Файл из архива успешно скопирован, переход к следующему файлу
        Else
incorrectaddress:
            MsgBox Promt3, vbInformation: End
        End If
NextEach:
        CheckFiles = CheckFiles + 1
    Next: If Folder <> OldDir Then ChDir OldDir 'Если папка была изменена, то возврат в прежнюю папку
    If Len(ArcName) Then Kill ArcName
End Function

как это будет работать в целом, код модуля формы:

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

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
Option Explicit
'
'   © Антихакер32™ Нативная DLL создаваемая по необходимости +Стильная иконка
'   И пример использования модуля SubClass
'   P.S Ничего устанавливать не нужно, требуется пустая форма
'
Const HTCAPTION = 2
Const WM_MOVE = &H3
Const WM_SIZE = &H5
Const WM_LBUTTONDOWN = &H201
Const WM_NCLBUTTONDOWN = &HA1
Dim WithEvents tx1 As TextBox
Dim WithEvents cm1 As CommandButton
Dim WithEvents cm2 As CommandButton
 
Private Declare Function Hooks Lib "MHook.dll" () As Object
'Экспортируемые функции
'Function AddChildHook(Child As Object, ByVal ParentProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от дочернего контрола
'    'Арг: Дочерний объект// вызываемое имя отцовой процедуры // сообщения окна
'    '
'Function AddParentHook(Child As Object, ByVal ChildProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от родительского окна
'    'Арг: Дочерний объект// вызываемое имя дочерней процедуры // сообщения окна
'    '
'Function AddHook(Obj As Object, ByVal ProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от указанного окна
'    'Арг: Объект// вызываемое имя процедуры // сообщения окна
'    '
'Function CloseHook(ByVal hwnd&) As Long
'    'Закрывает все хуки связанные с этим окном
'    'После этого можно останавливать программу
'    '
'Function CloseAllHooks() As Long
'    'Закрывает все ранее открытые хуки, и возвращает их число
    '
 
Dim h&, h1&
Dim mHooks As Object
 
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef IpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
 
 
Function CheckFiles(ByVal ZipUrl$, ByVal Folder$, ParamArray ParseNames()) As Long
    'Проверяет наличие файлов, указанных в аргументах ParseNames
    'И при необходимости докачивает их в указанную папку Folder
    'Если папка не указанна, то отсутствующие файлы будут скопированны в текущую папку
    '© Антихакер32™  ...2014
    '
    Const Promt0 = "Отсутствуют необходимые компоненты" & vbCrLf
    Const Promt1 = Promt0 & "Отсутствует соединение с интернетом, для того чтоб их скачать"
    Const Promt2 = Promt0 & "Указанный URL не является ZIP-папкой с компонентами"
    Const Promt3 = Promt0 & "URL не указан, либо указан неправильно"
    Dim vEach, OldDir$, ArcName$, f&, zExists As Boolean, s$, b() As Byte
    Dim ShellApp As Object, Fso As Object, Zip As Object
    Set Fso = CreateObject("Scripting.FileSystemObject"): OldDir = CurDir$
    If Fso.FolderExists(Folder) Then ChDir Folder Else Folder = OldDir
    For Each vEach In ParseNames
        If Fso.FileExists(vEach) Or Fso.FolderExists(vEach) Then
            GoTo NextEach
        ElseIf Len(ZipUrl) Then On Error Resume Next
            If Not zExists Then 'Обращение к интернету и закачка необходимых файлов
                If InternetGetConnectedState(0&, 0&) = 0 Then MsgBox Promt1, vbInformation: End
                f = 32: ArcName = Space$(f): Randomize Timer 'Случайное имя архива
                For f = 1 To f: Mid(ArcName, f, 1) = Chr(Asc("a") + Rnd * (Asc("z") - Asc("a")))
                Next: ArcName = ArcName & ".zip"
                If URLDownloadToFile(0, ZipUrl, ArcName, 0, 0) = 0 Then zExists = True Else GoTo incorrectaddress
                Set ShellApp = CreateObject("Shell.Application")
                Set Zip = ShellApp.NameSpace(Fso.GetAbsolutePathName(ArcName))
                If Zip Is Nothing Then MsgBox Promt2, vbInformation: Kill ArcName: End
            End If: 'On Error GoTo 0
            ShellApp.NameSpace((Folder)).CopyHere Zip.ParseName((vEach))
            f = FreeFile: Open CStr(vEach) For Binary As #f: ReDim Preserve b(LOF(f) - 1)
            Do: DoEvents: s = b: Get #f, 1, b: Loop While s <> CStr(b) 'Повторять пока есть разница данных
            Close #f 'Файл из архива успешно скопирован, переход к следующему файлу
        Else
incorrectaddress:
            MsgBox Promt3, vbInformation: End
        End If
NextEach:
        CheckFiles = CheckFiles + 1
    Next: If Folder <> OldDir Then ChDir OldDir 'Если папка была изменена, то возврат в прежнюю папку
    If Len(ArcName) Then Kill ArcName
End Function
 
Private Sub Form_Load()
    Dim c(1) As CommandButton, f&
    CheckFiles _
    "https://www.cyberforum.ru/blog_attachment.php?attachmentid=2468&d=1402890085" _
    , "", "MHook.dll", "PlasticFantastic Icon 13.ico"
    '-------------------------------------------------------------
    Me.Icon = LoadPicture("PlasticFantastic Icon 13.ico")
    Set mHooks = Hooks 'Загружаем класс
    
    Set tx1 = Controls.Add("vb.TextBox", "tx1")
    tx1.Move 100, 100, 4000, 500: tx1.Text = "Сдвинь меня !, и посмотри на стильную иконку"
    tx1.Visible = 1
    Set c(0) = Controls.Add("vb.CommandButton", "cm1")
    Set c(1) = Controls.Add("vb.CommandButton", "cm2")
    For f = 0 To 1: c(f).Move 100, 100 + (500 * f), 1500, 500
        c(f).Visible = 1: c(f).Caption = Choose(f + 1, "Закрыть хук", "Активировать хук")
    Next
    Set cm1 = c(0): Set cm2 = c(1)
    h1 = mHooks.AddHook(Me, "WMove", WM_MOVE)
End Sub
 
Private Sub cm2_Click()
    h1 = mHooks.AddChildHook(tx1, "TXMove", WM_LBUTTONDOWN)
End Sub
 
Private Sub cm1_Click()
    mHooks.CloseHook h1
End Sub
 
Public Function WMove(ParamArray Arg())
    Debug.Print Me.Left, Me.Top
End Function
 
Public Function TXMove(ParamArray Arg())
    Arg(2) = WM_NCLBUTTONDOWN
    Arg(3) = HTCAPTION
    TXMove = 1
End Function

Добавлено через 19 часов 57 минут
еще одна версия здесь, там вместо URLDownloadToFile, используется библиотека ...With CreateObject("MSXML2.XMLHTTP")

@Антихакер32 · 18.06.2014, 23:02

Реализация твоей темы оформления, полупрозрачности и невидимости

Теперь можно не задумываться как реализовать темы оформления (манифест) у вас в проекте,
достаточно иметь одну длл-ку которую не надо устанавливать
а только держать у себя на диске, а если ее вдруг не окажеться
этот код, быстренько найдет в интернете нужный (сильно сжатый) файл
и зальет тебе туда куда надо... причем следов от файла с манифестом
не остается, а звуковой файл и картинку можно не заливать..
ключевую роль там несет нативная длл *UpgradedVB.dll*

Добавлено через 1 час 41 минуту
ЗЫ...
Внес небольшую модификацию в код, теперь вместо пустого экрана
перед первой инициализацией возникнет маленькое сообщение

Добавлено через 14 часов 34 минуты
ЗЫ.. ЗЫ..
Внес еще одну важную поправку, связанную с CurDir и App.Path
для того чтоб запустить программу можно было из любого места

Код формы:

Самая правильная версия!

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
Option Explicit
'
'   Реализация твоей темы оформления, полупрозрачности и невидимости
'   На твоей единственной пустой форме, (фрейм можно удалить)
'   *примечание если нет манифеста, то темы оформления будут видны после компиляции
'   © Антихакер32™ ..2014
'
Private Type Rect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef IpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function Manifest Lib "UpgradedVB.dll" (ObjForm As Form) As Object
'Функции входящие в класс Manifest:
'Public Function FramesRePaint() As Long
'    'Перерисовка фреймов находящихся на форме, или пользовательском контроле
'    'Возврат количества в коллекции
'Public Sub Translucency(ByVal Alpha As Byte)
'    'Полупрозрачность
'    'Арг: Alpha [ 0-255 ]   ноль будет отключение полупрозрачности
'Public Sub Invisibility(Action As Boolean, Optional ColorKey& = &HFF00DC)
'    'Невидимость
'    'Арг: Вкл-выкл // Ключ прозрачности
'Public Function Sound(ByVal SoundName$)
'    'Функция воспроизведения звука
'    'Арг: Системный звуковой файл или файл из текущей папки
'    '
Dim Man As Object: Dim WithEvents img As Image
Dim WithEvents cm1 As CommandButton: Dim WithEvents cm2 As CommandButton
 
 
Private Sub cm1_Click() 'Реализация призрака
    If cm2.FontBold Then Exit Sub
    With cm1:  If .FontBold Then .FontBold = 0: Man.Translucency 0 _
        Else: .FontBold = 1: Man.Translucency 220
    End With: Man.Sound "Windows Vista Ballon.wav"
End Sub
 
Private Sub cm2_Click() 'Реализация невидимки
    If cm1.FontBold Then Exit Sub
    With cm2:  If .FontBold Then .FontBold = 0: Man.Invisibility 0 _
        Else: .FontBold = 1: Man.Invisibility 1
    End With: Man.Sound "Windows Vista Ballon.wav"
End Sub
 
Private Sub Command1_Click()
    Unload Me
End Sub
 
Private Sub Form_Load()
    Dim f&
    For f = 1 To 2: With Controls.Add("vb.CommandButton", "cm" & f)
            .Caption = Choose(f, "Полупрозрачность", "Невидимость")
            .Move Choose(f, 0, .Width * 2), 0, .Width * 2: .Visible = 1
    End With: Next
    Set cm1 = Controls("cm1"): Set cm2 = Controls("cm2")
    Set img = Controls.Add("vb.Image", "img")
    img.Move (Width - 2560) \ 2, (Height - 2560) \ 2, 2560, 2560
    img.Stretch = 1
    img.Picture = LoadPicture("PlasticFantastic Icon 04.ico")
    img.Visible = 1
 
End Sub
 
 
'Эти функции обеспечивают все эффекты, их лучше не трогать
Private Sub Form_Initialize()
    Dim bVar As Boolean, File_Manifest$
    '
    '
    '
    CheckFiles _
    "https://www.cyberforum.ru/blog_attachment.php?attachmentid=2481&d=1403038143" _
    , "", "UpgradedVB.dll", "PlasticFantastic Icon 04.ico", "Windows Vista Ballon.wav"
    '
    '
    '
    Const ConstManifest = "<?xml version=""1.0"" encoding=""UTF-8""?>%<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">% <assemblyIdentity% version=""1.1.0.0""% processorArchitecture=""X86""% name=""Manifest Creator""% type=""win32""% />% <description>Manifest Creation Application</description>% <dependency>% <dependentAssembly>% <assemblyIdentity% type=""win32""% name=""Microsoft.Windows.Common-Controls""% version=""6.0.0.0""% processorArchitecture=""X86""% publicKeyToken=""6595b64144ccf1df""% language=""*""% />% </dependentAssembly>% </dependency>%<!-- Identify the application security requirements: Vista and above -->% <trustInfo xmlns=""urn:schemas-microsoft-com:asm.v2"">% <security>% <requestedPrivileges>% <requestedExecutionLevel% level=""asInvoker""% uiAccess=""false""% />% </requestedPrivileges>% </security>% </trustInfo>%</assembly>"
    With CreateObject("Scripting.FileSystemObject")
        File_Manifest = App.EXEName & ".exe.MANIFEST"
        Debug.Assert DebugIDE(bVar) 'Эта процедура не выполниться в скомпиленном файле
        If Not .FileExists(File_Manifest) And Not bVar Then
            With .CreateTextFile(File_Manifest):  .Write Replace(ConstManifest, "%", vbCrLf): .Close: End With
            Shell App.EXEName, vbNormalFocus: End
        End If: Set Man = Manifest(Me): If Not bVar Then Kill File_Manifest
        Man.FramesRePaint
    End With
End Sub
 
Function CheckFiles(ByVal ZipUrl$, ByVal Folder$, ParamArray ParseNames()) As Long
    'Проверяет наличие файлов, указанных в аргументах ParseNames
    'И при необходимости докачивает их в указанную папку Folder
    'Если папка не указанна, то отсутствующие файлы будут скопированны в текущую папку
    '© Антихакер32™  ...2014
    '
    Const Promt0 = "Отсутствуют необходимые компоненты" & vbCrLf
    Const Promt1 = Promt0 & "Отсутствует соединение с интернетом, для того чтоб их скачать"
    Const Promt2 = Promt0 & "Указанный URL не является ZIP-папкой с компонентами"
    Const Promt3 = Promt0 & "URL Zip-папки, указан неправильно"
    Dim vEach, OldDir$, ArcName$, f&, zExists As Boolean, s$, i&, b() As Byte
    Dim ShellApp As Object, Zip As Object, Rect As Rect, MinWin&, Fso As Object
    Set Fso = CreateObject("Scripting.FileSystemObject"): OldDir = CurDir$
    If Fso.FolderExists(Folder) Then ChDir Fso.GetAbsolutePathName(Folder) Else ChDir App.Path
    For Each vEach In ParseNames
        If Fso.FileExists(vEach) Or Fso.FolderExists(vEach) Then
            CheckFiles = CheckFiles + 1: GoTo NextEach
        ElseIf Len(ZipUrl) Then On Error Resume Next
            If Not zExists Then 'Обращение к интернету и закачка необходимых файлов
                GetWindowRect GetDesktopWindow, Rect 'Маленькая надпись
                MinWin = CreateWindowEx(0&, "STATIC", ">>--- Загрузка ---<<", &H50800000, _
                (Rect.Right - 150) / 2, (Rect.Bottom - 20) / 2, 150, 20, GetDesktopWindow, 0&, 0, ByVal 0&)
                '
                i = Len(ZipUrl): ArcName = ZipUrl
                For f = 1 To i: If Mid$(ArcName, f, 1) Like "[!0-9!A-Z!a-z]" Then Mid$(ArcName, f, 1) = "_"
                Next: ArcName = ArcName & ".zip"
                If InternetGetConnectedState(0&, 0&) = 0 Then MsgBox Promt1, vbInformation: End
                If URLDownloadToFile(0, ZipUrl, ArcName, 0, 0) Then MsgBox Promt3, vbInformation: End
                Set ShellApp = CreateObject("Shell.Application")
                Set Zip = ShellApp.NameSpace(Fso.GetAbsolutePathName(ArcName)): zExists = Zip.Items.Count
                If Not zExists Then MsgBox Promt2, vbInformation: Kill ArcName: End
            End If: 'On Error GoTo 0
            If Zip.ParseName((vEach)) Is Nothing Then GoTo NextEach
            ShellApp.NameSpace((CurDir$)).CopyHere Zip.ParseName((vEach))
            f = FreeFile: Open CStr(vEach) For Binary As #f: ReDim b(LOF(f) - 1)
            Do: DoEvents: s = b: Get #f, 1, b: Loop While s <> CStr(b) 'пока есть разница данных
            Close #f: CheckFiles = CheckFiles + 1 'Файл из архива успешно скопирован, переход к следующему файлу
        Else: MsgBox Promt3, vbInformation: End
        End If
NextEach:
    Next: If Len(ArcName) Then Kill ArcName
    If MinWin Then DestroyWindow MinWin
    If CurDir$ <> OldDir Then ChDir OldDir 'Если папка была изменена, то возврат в прежнюю папку
End Function
'
Public Function DebugIDE(ByRef bVar As Boolean) As Boolean: bVar = True: DebugIDE = True: End Function
'

Старая версия, оставил для сравнения

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
Option Explicit
'
'   Реализация твоей темы оформления, полупрозрачности и невидимости
'   На твоей единственной пустой форме, (фрейм можно удалить)
'   *примечание если нет манифеста, то темы оформления будут видны после компиляции
'   © Антихакер32™ ..2014
'
Private Type Rect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef IpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function Manifest Lib "UpgradedVB.dll" (ObjForm As Form) As Object
'Функции входящие в класс Manifest:
'Public Function FramesRePaint() As Long
'    'Перерисовка фреймов находящихся на форме, или пользовательском контроле
'    'Возврат количества в коллекции
'Public Sub Translucency(ByVal Alpha As Byte)
'    'Полупрозрачность
'    'Арг: Alpha [ 0-255 ]   ноль будет отключение полупрозрачности
'Public Sub Invisibility(Action As Boolean, Optional ColorKey& = &HFF00DC)
'    'Невидимость
'    'Арг: Вкл-выкл // Ключ прозрачности
'Public Function Sound(ByVal SoundName$)
'    'Функция воспроизведения звука
'    'Арг: Системный звуковой файл или файл из текущей папки
'    '
Dim Man As Object: Dim WithEvents img As Image
Dim WithEvents cm1 As CommandButton: Dim WithEvents cm2 As CommandButton
 
Private Sub cm1_Click() 'Реализация призрака
    If cm2.FontBold Then Exit Sub
    With cm1:  If .FontBold Then .FontBold = 0: Man.Translucency 0 _
        Else: .FontBold = 1: Man.Translucency 220
    End With: Man.Sound "Windows Vista Ballon.wav"
End Sub
 
Private Sub cm2_Click() 'Реализация невидимки
    If cm1.FontBold Then Exit Sub
    With cm2:  If .FontBold Then .FontBold = 0: Man.Invisibility 0 _
        Else: .FontBold = 1: Man.Invisibility 1
    End With: Man.Sound "Windows Vista Ballon.wav"
End Sub
 
Private Sub Command1_Click()
    Unload Me
End Sub
 
Private Sub Form_Load()
    Dim f&
    For f = 1 To 2: With Controls.Add("vb.CommandButton", "cm" & f)
            .Caption = Choose(f, "Полупрозрачность", "Невидимость")
            .Move Choose(f, 0, .Width * 2), 0, .Width * 2: .Visible = 1
    End With: Next
    Set cm1 = Controls("cm1"): Set cm2 = Controls("cm2")
    Set img = Controls.Add("vb.Image", "img")
    img.Move (Width - 2560) \ 2, (Height - 2560) \ 2, 2560, 2560
    img.Stretch = 1
    img.Picture = LoadPicture("PlasticFantastic Icon 04.ico")
    img.Visible = 1
 
End Sub
 
 
'Эти функции обеспечивают все эффекты, их лучше не трогать
Private Sub Form_Initialize()
    Dim bVar As Boolean, File_Manifest$
    '
    '
    '
    CheckFiles _
    "https://www.cyberforum.ru/blog_attachment.php?attachmentid=2481&d=1403038143" _
    , "", "UpgradedVB.dll", "PlasticFantastic Icon 04.ico", "Windows Vista Ballon.wav"
    '
    '
    '
    Const ConstManifest = "<?xml version=""1.0"" encoding=""UTF-8""?>%<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">% <assemblyIdentity% version=""1.1.0.0""% processorArchitecture=""X86""% name=""Manifest Creator""% type=""win32""% />% <description>Manifest Creation Application</description>% <dependency>% <dependentAssembly>% <assemblyIdentity% type=""win32""% name=""Microsoft.Windows.Common-Controls""% version=""6.0.0.0""% processorArchitecture=""X86""% publicKeyToken=""6595b64144ccf1df""% language=""*""% />% </dependentAssembly>% </dependency>%<!-- Identify the application security requirements: Vista and above -->% <trustInfo xmlns=""urn:schemas-microsoft-com:asm.v2"">% <security>% <requestedPrivileges>% <requestedExecutionLevel% level=""asInvoker""% uiAccess=""false""% />% </requestedPrivileges>% </security>% </trustInfo>%</assembly>"
    With CreateObject("Scripting.FileSystemObject")
        File_Manifest = App.EXEName & ".exe.MANIFEST"
        Debug.Assert DebugIDE(bVar) 'Эта процедура не выполниться в скомпиленном файле
        If Not .FileExists(File_Manifest) And Not bVar Then
            With .CreateTextFile(File_Manifest):  .Write Replace(ConstManifest, "%", vbCrLf): .Close: End With
            Shell App.EXEName, vbNormalFocus: End
        End If: Set Man = Manifest(Me): If Not bVar Then Kill File_Manifest
        Man.FramesRePaint
    End With
End Sub
 
 
Function CheckFiles(ByVal ZipUrl$, ByVal Folder$, ParamArray ParseNames()) As Long
    'Проверяет наличие файлов, указанных в аргументах ParseNames
    'И при необходимости докачивает их в указанную папку Folder
    'Если папка не указанна, то отсутствующие файлы будут скопированны в текущую папку
    '© Антихакер32™  ...2014
    '
    Const Promt0 = "Отсутствуют необходимые компоненты" & vbCrLf
    Const Promt1 = Promt0 & "Отсутствует соединение с интернетом, для того чтоб их скачать"
    Const Promt2 = Promt0 & "Указанный URL не является ZIP-папкой с компонентами"
    Const Promt3 = Promt0 & "URL Zip-папки, указан неправильно"
    Dim vEach, OldDir$, ArcName$, f&, zExists As Boolean, s$, i&, b() As Byte
    Dim ShellApp As Object, Fso As Object, Zip As Object, Rect As Rect, MinWin&
    Set Fso = CreateObject("Scripting.FileSystemObject"): OldDir = CurDir$
    If Fso.FolderExists(Folder) Then ChDir Folder Else Folder = OldDir
    For Each vEach In ParseNames
        If Fso.FileExists(vEach) Or Fso.FolderExists(vEach) Then
            CheckFiles = CheckFiles + 1: GoTo NextEach
        ElseIf Len(ZipUrl) Then On Error Resume Next
            If Not zExists Then 'Обращение к интернету и закачка необходимых файлов
                GetWindowRect GetDesktopWindow, Rect 'Маленькая надпись
                MinWin = CreateWindowEx(0&, "STATIC", ">>--- Загрузка ---<<", &H50800000, _
                (Rect.Right - 150) / 2, (Rect.Bottom - 20) / 2, 150, 20, GetDesktopWindow, 0&, 0, ByVal 0&)
                '
                i = Len(ZipUrl): ArcName = ZipUrl
                For f = 1 To i: If Mid$(ArcName, f, 1) Like "[!0-9!A-Z!a-z]" Then Mid$(ArcName, f, 1) = "_"
                Next: ArcName = ArcName & ".zip"
                If InternetGetConnectedState(0&, 0&) = 0 Then MsgBox Promt1, vbInformation: End
                If URLDownloadToFile(0, ZipUrl, ArcName, 0, 0) Then MsgBox Promt3, vbInformation: End
                Set ShellApp = CreateObject("Shell.Application")
                Set Zip = ShellApp.NameSpace(Fso.GetAbsolutePathName(ArcName)): zExists = Zip.Items.Count
                If Not zExists Then MsgBox Promt2, vbInformation: Kill ArcName: End
            End If: 'On Error GoTo 0
            If Zip.ParseName((vEach)) Is Nothing Then GoTo NextEach
            ShellApp.NameSpace((Folder)).CopyHere Zip.ParseName((vEach))
            f = FreeFile: Open CStr(vEach) For Binary As #f: ReDim b(LOF(f) - 1)
            Do: DoEvents: s = b: Get #f, 1, b: Loop While s <> CStr(b) 'пока есть разница данных
            Close #f: CheckFiles = CheckFiles + 1 'Файл из архива успешно скопирован, переход к следующему файлу
        Else: MsgBox Promt3, vbInformation: End
        End If
NextEach:
    Next: If Len(ArcName) Then Kill ArcName
    If MinWin Then DestroyWindow MinWin
    If Folder <> OldDir Then ChDir OldDir 'Если папка была изменена, то возврат в прежнюю папку
End Function
'
Public Function DebugIDE(ByRef bVar As Boolean) As Boolean: bVar = True: DebugIDE = True: End Function
'

@Антихакер32 · 20.06.2014, 07:42

Анимация надписи

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Explicit
'
'   © Антихакер32™ // Анимация надписи
'
Const MaxStr = "....."
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong 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
Dim WithEvents lab As Label, WithEvents tmr As Timer
 
Private Sub tmr_Timer()
    Static s$, l&
    If s = "" Then s = Replace(lab.Caption, MaxStr, vbNullString)
    If l > Len(MaxStr) Then l = 0 Else l = l + 1
    lab.Caption = s & String(l, Asc(MaxStr))
End Sub
Private Sub Form_Load()
    Set lab = Controls.Add("vb.Label", "lab")
    With lab: lab.BackStyle = 0: .Caption = "Загрузка " & MaxStr: .AutoSize = 1: lab.FontSize = 32: .ForeColor = &HFFFF&: .FontName = "Arial Black": .Visible = 1: End With
    Set tmr = Controls.Add("vb.Timer", "tmr"): tmr.Interval = 100
    '
    Me.BackColor = &HFF00DC
    SetWindowLong hwnd, -20, GetWindowLong(hwnd, -20) Or &H80000
    SetLayeredWindowAttributes hwnd, &HFF00DC, 0, 1
    Me.Move (Screen.Width - lab.Width) \ 2, (Screen.Height - lab.Height) \ 2, lab.Width, lab.Height
    SetWindowPos hwnd, -1, 0, 0, 0, 0, 3
End Sub

То-же самое, только с объемом и тенью

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Option Explicit
'
'   © Антихакер32™ // Анимация надписи
'
Const MaxStr = "....."
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong 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
Dim WithEvents lab As Label, WithEvents tmr As Timer, shadow As Label
Private Sub tmr_Timer()
    Static s$, l&
    If s = "" Then s = Replace(lab.Caption, MaxStr, vbNullString)
    If l > Len(MaxStr) Then l = 0 Else l = l + 1:  lab.Caption = s & String(l, Asc(MaxStr)): shadow = lab
End Sub
Private Sub Form_Load()
    Set lab = Controls.Add("vb.Label", "lab")
    With lab: .BackStyle = 0: .Caption = "Загрузка " & MaxStr: .AutoSize = 1: .FontSize = 32: .ForeColor = &HFFFF&: .FontName = "Arial Black": .Visible = 1: End With
    Set shadow = Controls.Add("vb.Label", "shadow")
    With shadow: .BackStyle = 0: .Caption = lab: .AutoSize = 1: .FontSize = 32: .ForeColor = &H80000010: .FontName = "Arial Black": .Visible = 1: .Move Screen.TwipsPerPixelX * 3, Screen.TwipsPerPixelY * 3: .ZOrder 1: End With
    Set tmr = Controls.Add("vb.Timer", "tmr"): tmr.Interval = 100
    '
    Me.BackColor = 16 '
    SetWindowLong hwnd, -20, GetWindowLong(hwnd, -20) Or &H80000
    SetLayeredWindowAttributes hwnd, 16, 0, 1
    Me.Move (Screen.Width - lab.Width) \ 2, (Screen.Height - lab.Height) \ 2, lab.Width, lab.Height
    SetWindowPos hwnd, -1, 0, 0, 0, 0, 3
End Sub

Добавлено через 2 минуты
ЗЫ...
для полного эфекта "голой надписи" следует установить свойства формы:
BorderStyle = 0 (None)

Dragokas · 10.08.2014, 17:21 **[ТС]**

Batch Resource Packer
Упаковка бинарных ресурсов в батник по методу Cabinet's Batch inline by Dragokas

Примечание:
Если программа не захочет запускаться, сославшись на отсутствие библиотек:
1) Запустите от имени администратора батник "Зарегистрировать библиотеки.cmd"
или
2) Скопируйте библиотеки из папки "lib" в корневую папку с EXE-шником.
Возможно, потребуется запустить EXE файл один раз от имени Администратора.

@Антихакер32 · 23.08.2014, 13:15

Анимация надписи 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
Option Explicit
'
'   © Антихакер32™ // Анимация надписи
'
Const MaxStr = "....."
Private Const GWL_EXSTYLE = -20
Private Const GWL_STYLE = -16
Private Const LWA_COLORKEY = &H1
Private Const WS_EX_LAYERED As Long = &H80000
Private Const WS_CHILD = &H40000000
 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong 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
Dim WithEvents lab As Label, WithEvents tmr As Timer
 
Private Sub tmr_Timer()
    Static s$, l&
    If s = "" Then s = Replace(lab.Caption, MaxStr, vbNullString)
    If l > Len(MaxStr) Then l = 0 Else l = l + 1
    lab.Caption = s & String(l, Asc(MaxStr))
End Sub
Private Sub Form_Load()
    Set lab = Controls.Add("vb.Label", "lab")
    With lab: lab.BackStyle = 0: .Caption = "Загрузка " & MaxStr: .AutoSize = 1: lab.FontSize = 32: .ForeColor = &HFFFF&: .FontName = "Arial Black": .Visible = 1: End With
    Set tmr = Controls.Add("vb.Timer", "tmr"): tmr.Interval = 100
    '
    Me.BackColor = &HFF00DC
    SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd, Me.BackColor, 0, 1
    Me.Move (Screen.Width - lab.Width) \ 2, (Screen.Height - lab.Height) \ 2, lab.Width, lab.Height
    SetWindowLong hwnd, GWL_STYLE, WS_CHILD
    SetWindowPos hwnd, -1, 0, 0, 0, 0, 3 'Поверх всех окон без изменения размеров
End Sub

Добавлено через 7 минут

Не по теме:

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

Добавлено через 2 минуты
Из новинок....

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Option Explicit
 
Private Sub Form_Load()
    Dim s$
    s = "https://m.vk.com/away.php?to=http%3A%2F%2Frghost.ru%2F57584575"
    s = CV_HTTP_VK_Link$(s)
End Sub
 
Function CV_HTTP_VK_Link$(ByVal Link$, Optional Compare As VbCompareMethod = 1)
    'Получение нормальной ссылки, если сайт VK ее шифрует
    '
    Const in1 = "?to=", rp1 = "%3A", rp2 = "%2F"
    Dim n&
    n = InStr(1, Link, in1, Compare)
    n = n + Len(in1) * Sgn(n) + Abs(n = 0)
    Link = Mid$(Link, n)
    Link = Replace(Link, rp1, ":", , , Compare)
    CV_HTTP_VK_Link = Replace(Link, rp2, "/", , , Compare)
End Function

Новые блоги и статьи Все статьи Все блоги /
Мысли в слух. Про "навсегда". kumehtar 16.04.2026 Подумалось тут, что наверное очень глупо использовать во всяких своих установках понятие "навсегда". Это очень сильное понятие, и я только начинаю понимать край его смысла, не смотря на то что давно. . .	My Business CRM MaGz GoLd 16.04.2026 Всем привет, недавно возникла потребность создать CRM, для личных нужд. Собственно программа предоставляет из себя базу данных клиентов, в которой можно фиксировать звонки, стадии сделки, а также. . .	Знаешь почему 90% людей редко бывают счастливыми? kumehtar 14.04.2026 Потому что они ждут. Ждут выходных, ждут отпуска, ждут удачного момента. . . а удачный момент так и не приходит.	Фиксация колонок в отчете СКД Maks 14.04.2026 Фиксация колонок в СКД отчета типа Таблица. Задача: зафиксировать три левых колонки в отчете. Процедура ПриКомпоновкеРезультата(ДокументРезультат, ДанныеРасшифровки, СтандартнаяОбработка) / / . . .
Настройки VS Code Loafer 13.04.2026 { "cmake. configureOnOpen": false, "diffEditor. ignoreTrimWhitespace": true, "editor. guides. bracketPairs": "active", "extensions. ignoreRecommendations": true, . . .	Оптимизация кода на разграничение прав доступа к элементам формы Maks 13.04.2026 Алгоритм из решения ниже реализован на нетиповом документе, разработанного в конфигурации КА2. Задачи, как таковой, поставлено не было, проделанное ниже исключительно моя инициатива. Было так:. . .	Контроль заполнения и очистка дат в зависимости от значения перечислений Maks 12.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "ПланированиеПерсонала", разработанного в конфигурации КА2. Задача: реализовать контроль корректности заполнения дат назначения. . .	Архитектура слоя интернета для сервера-слоя. Hrethgir 11.04.2026 В продолжение https:/ / www. cyberforum. ru/ blogs/ 223907/ 10860. html Знаешь что я подумал? Раз мы все источники пишем в голове ветки, то ничего не мешает добавить в голову такой источник, который сам. . .

@Антихакер32 1201 / 473 / 46 Регистрация: 06.01.2014 Сообщений: 1,797 Записей в блоге: 19
	28.05.2014, 06:00
	ActiveX EXE Что такое ActiveX EXE ? Зачем нужна ActiveX EXE, и с чем её едят читайте здесь перемещаемая папка: вызов приложения из архива 1

@The trick Модератор 10057 / 3902 / 884 Регистрация: 22.02.2013 Сообщений: 5,853 Записей в блоге: 79
	30.05.2014, 11:11
	Использование COM/ActiveX библиотек без регистрации в реестре. Привет всем. Выкладываю модуль для работы с COM-Dll без регистрации в реестре. Модуль имеет несколько функций: GetAllCoclasses - возвращает список имен классов вместе с идентификаторами извлеченными из библиотеки типов. CreateIDispatch - создает реализацию IDispatch на основе объекта и имени интерфейса. CreateObjectEx2 - создает объект по имени. CreateObjectEx - создает объект по CLSID. UnloadLibrary - Выгружает библиотеку, если та не используется. Ссылка. 6

@The trick Модератор 10057 / 3902 / 884 Регистрация: 22.02.2013 Сообщений: 5,853 Записей в блоге: 79
	31.05.2014, 03:00
	Модуль для перехвата функций на VB6 Разработал простой модуль с помощью которого можно перехватывать STDCALL функции и методы COM объектов. Перехват реализован с помощью сплайсинга, никаких синхронизаций нет, так что в многопоточной программе могут возникнуть проблемы. Пользоваться нужно осторожно, т.к. любая ошибка фатальна, нельзя вызывать перехваченную функцию, если не снят перехват, т.к. произойдет переполнение стека. Перехват может понадобится во многих случаях, в примере я использую перехват для создания многострочного текстбокса в рантайме. Ссылка. 3

@Антихакер32 1201 / 473 / 46 Регистрация: 06.01.2014 Сообщений: 1,797 Записей в блоге: 19
	13.06.2014, 00:31
	*Полупрозрачный Диспетчер задач.. ✰* исполненно на бейсике, одним модулем.. я даже весь проект не стал отправлять, забросил в архив только форму Форма в архиве: >>✰ DownLoad ✰<< 2

@The trick Модератор 10057 / 3902 / 884 Регистрация: 22.02.2013 Сообщений: 5,853 Записей в блоге: 79
	16.06.2014, 01:05
	Класс для сабклассинга окон и классов. Разработал класс с помощью которого можно работать с сабклассингом. Класс имеет событие WndProc, которое вызывается при получении окном сообщения. Также имеется возможность поставить сабклассинг на класс окон. Имеются методы для приостановки сабклассинга и снятия его, а также получения информации о сабклассинге. Работать очень удобно, т.к. можно останавливать проект кнопкой стоп без последствий. Запускать лучше через Start with full compile, т.к. это предотвратит вылеты, при неудачной компиляции. Я себе вообще вывел отдельно кнопку рядом с обычной компиляцией, и пользуюсь ей. Немного о работе с классом. Для установки сабклассинга на окно, вызывается метод Hook, с хендлом окна. Если метод возвращает True, значит сабклассинг установлен. Обрабатывая событие WndProc, можно изменять поведение окна. В аргумент Ret можно передавать возвращаемое значение, если нужно вызвать процедуру по умолчанию, то нужно передать в аргументе DefCall True. Для установки сабклассинга на группу окон (класс), нужно вызвать метод HookClass, передавая хендл окна чей класс нужно засабклассировать. При удачном выполнении метод вернет True. Сабклассинг будет действовать начиная со следующего созданного окна этого класса, т.е. на переданный параметр сабклассинг действовать не будет. Также по умолчанию этот вид сабклассинга приостановлен. Я сделал это из-за того, что если не обработать сообщения создания окон должным образом, то проект не запустится с ошибкой Out of memory. Для снятия сабклассинга нужно вызвать метод Unhook, возвращающий True при удачном выполнении. Для приостановки и возобновления сабклассинга предусмотрены методы PauseSubclass и ResumeSubclass, возвращающие True при удачном выполнении. Свойство hWnd возвращает хендл окна, на который установлен сабклассинг (для случая установки сабклассинга на класс окон, возвращает переданный параметр). Свойство IsSubclassed предназначено для определения, установлен ли сабклассинг или нет. Свойство IsClass возвращает True, если сабклассинг устанавливался на класс окон. Свойство IsPaused возвращает True, если сабклассинг приостановлен. Для теста я сделал небольшой проект, в котором используются возможности сабклассинга. Установка таймера (SetTimer), замена стандартного контекстного меню текстбокса, ограничение на изменение размеров формы, отлов "прихода"/"ухода" мыши на/из котрол(а). Ссылка. 5