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
| Option Explicit
' Модуль для создания окна с циклом обработки сообщений в новом потоке
' © Кривоус Анатолий Анатольевич (The trick), 2014
' Работает только в скомпилированном в Native коде
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type Msg
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Type WNDCLASS
style As Long
lpfnwndproc As Long
cbClsextra As Long
cbWndExtra2 As Long
hInstance As Long
hIcon As Long
hCursor As Long
hbrBackground As Long
lpszMenuName As Long
lpszClassName As String
End Type
Public Const INFINITE = &HFFFF
Public Const WS_CHILD = &H40000000
Public Const WS_CLIPCHILDREN = &H2000000
Public Const WS_SYSMENU = &H80000
Public Const CS_VREDRAW = &H1
Public Const CS_HREDRAW = &H2
Public Const CS_CLASSDC = &H40
Public Const WM_DESTROY = &H2
Public Const WM_COMMAND = &H111
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_MOUSEMOVE = &H200
Public Const WM_CLOSE = &H10
Public Const WM_QUIT = &H12
Public Const WM_SETFONT = &H30
Public Const IDC_ARROW = 32512&
Public Const GWL_WNDPROC = (-4)
Public Const CW_USEDEFAULT = &H80000000
Public Const COLOR_WINDOW = 5
Public Const IDI_APPLICATION = 32512&
Public Const SW_SHOWNORMAL = 1
Public Const MB_ICONEXCLAMATION = &H30&
Public hWnds() As Long, Count As Long, RegClass As Long, hMutex As Long, _
TlsIndex As Long, ClassNameAnsi As String, hInstance As Long, hFont As Long
Public Function ThreadProc(ByVal Name As String) As Long
TlsSetValue TlsIndex, 0 ' Флаг рисования = 0
NewWindow Name
End Function
Public Function NewWindow(Name As String) As Boolean
Dim wMsg As Msg
Dim PntWnd As Long, ButWnd As Long
WaitForSingleObject hMutex, INFINITE ' Останавливаем пока мьютекс захвачен
If RegClass = False Then
If Not RegisterWindowClass Then ReleaseMutex hMutex: Exit Function
RegClass = True
'MessageBox 0, "Class registered", "test", MB_ICONEXCLAMATION
End If
PntWnd = CreateWindowEx(0, "TrickWindow", Name, WS_SYSMENU Or WS_CLIPCHILDREN, CW_USEDEFAULT, CW_USEDEFAULT, 400, 400, 0, 0, App.hInstance, ByVal 0&)
ButWnd = CreateWindowEx(0, "Button", "Sleep(10000)", WS_CHILD, 150, 175, 100, 50, PntWnd, 1, App.hInstance, ByVal 0&)
SendMessage ButWnd, WM_SETFONT, hFont, 1
Call ShowWindow(PntWnd, SW_SHOWNORMAL)
Call ShowWindow(ButWnd, SW_SHOWNORMAL)
ReDim Preserve hWnds(Count)
hWnds(Count) = PntWnd
Count = Count + 1
ReleaseMutex hMutex ' Даем другим потокам создать окна
Do While GetMessage(wMsg, 0&, 0&, 0&)
Call TranslateMessage(wMsg)
Call DispatchMessage(wMsg)
Loop
WaitForSingleObject hMutex, INFINITE ' Если вдруг окно создается
Count = Count - 1
If Count = 0 Then
UnregisterClass "TrickWindow", App.hInstance
RegClass = False
'MessageBox 0, "Class unregistered", "test", MB_ICONEXCLAMATION
End If
ReleaseMutex hMutex
End Function
Public Function RegisterWindowClass() As Boolean
Dim wc As WNDCLASS
wc.style = CS_HREDRAW Or CS_VREDRAW Or CS_CLASSDC
wc.lpfnwndproc = GetAddr(AddressOf WndProc)
wc.hInstance = hInstance
wc.hIcon = LoadIcon(0&, IDI_APPLICATION)
wc.hCursor = LoadCursor(0&, IDC_ARROW)
wc.hbrBackground = COLOR_WINDOW
wc.lpszClassName = ClassNameAnsi
RegisterWindowClass = RegisterClass(wc)
End Function
Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim x As Integer, y As Integer, r As Long, dc As Long
Select Case uMsg&
Case WM_COMMAND
If wParam = 1 Then
Call Sleep_Click
End If
Case WM_LBUTTONDOWN
SetCapture hwnd
x = lParam And &HFFFF&
y = (lParam \ &H10000) And &HFFFF&
TlsSetValue TlsIndex, 1
dc = GetDC(hwnd)
MoveToEx dc, x, y, ByVal 0&
ReleaseDC hwnd, dc
Case WM_LBUTTONUP
ReleaseCapture
TlsSetValue TlsIndex, 0
Case WM_MOUSEMOVE
x = lParam And &HFFFF&
y = (lParam \ &H10000) And &HFFFF&
r = TlsGetValue(TlsIndex)
If r = 1 Then
dc = GetDC(hwnd)
LineTo dc, x, y
ReleaseDC hwnd, dc
End If
Case WM_DESTROY: Call PostQuitMessage(0&)
End Select
WndProc = DefWindowProc(hwnd&, uMsg&, wParam&, lParam&)
End Function
Private Sub Sleep_Click()
Sleep 10000
End Sub
Private Function GetAddr(Addr As Long) As Long
GetAddr = Addr
End Function |
